notmuch-tree.el (54777B)
1 ;;; notmuch-tree.el --- displaying notmuch forests -*- lexical-binding: t -*- 2 ;; 3 ;; Copyright © Carl Worth 4 ;; Copyright © David Edmondson 5 ;; Copyright © Mark Walters 6 ;; 7 ;; This file is part of Notmuch. 8 ;; 9 ;; Notmuch is free software: you can redistribute it and/or modify it 10 ;; under the terms of the GNU General Public License as published by 11 ;; the Free Software Foundation, either version 3 of the License, or 12 ;; (at your option) any later version. 13 ;; 14 ;; Notmuch is distributed in the hope that it will be useful, but 15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;; General Public License for more details. 18 ;; 19 ;; You should have received a copy of the GNU General Public License 20 ;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>. 21 ;; 22 ;; Authors: David Edmondson <dme@dme.org> 23 ;; Mark Walters <markwalters1009@gmail.com> 24 25 ;;; Code: 26 27 (require 'mail-parse) 28 29 (require 'notmuch-lib) 30 (require 'notmuch-show) 31 (require 'notmuch-tag) 32 (require 'notmuch-parser) 33 (require 'notmuch-jump) 34 35 (declare-function notmuch-search "notmuch" 36 (&optional query oldest-first target-thread target-line 37 no-display)) 38 (declare-function notmuch-call-notmuch-process "notmuch-lib" (&rest args)) 39 (declare-function notmuch-read-query "notmuch" (prompt)) 40 (declare-function notmuch-search-find-thread-id "notmuch" (&optional bare)) 41 (declare-function notmuch-search-find-subject "notmuch" ()) 42 43 ;; For `notmuch-tree-next-thread-from-search'. 44 (declare-function notmuch-search-next-thread "notmuch" ()) 45 (declare-function notmuch-search-previous-thread "notmuch" ()) 46 (declare-function notmuch-tree-from-search-thread "notmuch" ()) 47 48 ;; this variable distinguishes the unthreaded display from the normal tree display 49 (defvar-local notmuch-tree-unthreaded nil 50 "A buffer local copy of argument unthreaded to the function notmuch-tree.") 51 52 ;;; Options 53 54 (defgroup notmuch-tree nil 55 "Showing message and thread structure." 56 :group 'notmuch) 57 58 (defcustom notmuch-tree-show-out nil 59 "View selected messages in new window rather than split-pane." 60 :type 'boolean 61 :group 'notmuch-tree) 62 63 (defcustom notmuch-unthreaded-show-out t 64 "View selected messages in new window rather than split-pane." 65 :type 'boolean 66 :group 'notmuch-tree) 67 68 (defun notmuch-tree-show-out () 69 (if notmuch-tree-unthreaded 70 notmuch-unthreaded-show-out 71 notmuch-tree-show-out)) 72 73 (defcustom notmuch-tree-thread-symbols 74 '((prefix . " ") 75 (top . "─") 76 (top-tee . "┬") 77 (vertical . "│") 78 (vertical-tee . "├") 79 (bottom . "╰") 80 (arrow . "►")) 81 "Strings used to draw trees in notmuch tree results. 82 Symbol keys denote where the corresponding string value is used: 83 `prefix' is used at the top of the tree, followed by `top' if it 84 has no children or `top-tee' if it does; `vertical' is a bar 85 connecting with a response down the list skipping the current 86 one, while `vertical-tee' marks the current message as a reply to 87 the previous one; `bottom' is used at the bottom of threads. 88 Finally, the `arrrow' string in the list is used as a pointer to 89 every message. 90 91 Common customizations include setting `prefix' to \"-\", to see 92 equal-length prefixes, and `arrow' to an empty string or to a 93 different kind of arrow point." 94 :type '(alist :key-type symbol :value-type string) 95 :group 'notmuch-tree) 96 97 (defconst notmuch-tree--field-names 98 '(choice :tag "Field" 99 (const :tag "Date" "date") 100 (const :tag "Authors" "authors") 101 (const :tag "Subject" "subject") 102 (const :tag "Tree" "tree") 103 (const :tag "Tags" "tags") 104 (function))) 105 106 (defcustom notmuch-tree-result-format 107 `(("date" . "%12s ") 108 ("authors" . "%-20s") 109 ((("tree" . "%s") 110 ("subject" . "%s")) 111 . " %-54s ") 112 ("tags" . "(%s)")) 113 "Result formatting for tree view. 114 115 List of pairs of (field . format-string). Supported field 116 strings are: \"date\", \"authors\", \"subject\", \"tree\", 117 \"tags\". It is also supported to pass a function in place of a 118 field-name. In this case the function is passed the thread 119 object (plist) and format string. 120 121 Tree means the thread tree box graphics. The field may 122 also be a list in which case the formatting rules are 123 applied recursively and then the output of all the fields 124 in the list is inserted according to format-string. 125 126 Note that the author string should not contain whitespace 127 \(put it in the neighbouring fields instead)." 128 129 :type `(alist :key-type (choice ,notmuch-tree--field-names 130 (alist :key-type ,notmuch-tree--field-names 131 :value-type (string :tag "Format"))) 132 :value-type (string :tag "Format")) 133 :group 'notmuch-tree) 134 135 (defcustom notmuch-unthreaded-result-format 136 `(("date" . "%12s ") 137 ("authors" . "%-20s") 138 ((("subject" . "%s")) ." %-54s ") 139 ("tags" . "(%s)")) 140 "Result formatting for unthreaded tree view. 141 142 List of pairs of (field . format-string). Supported field 143 strings are: \"date\", \"authors\", \"subject\", \"tree\", 144 \"tags\". It is also supported to pass a function in place of a 145 field-name. In this case the function is passed the thread 146 object (plist) and format string. 147 148 Tree means the thread tree box graphics. The field may 149 also be a list in which case the formatting rules are 150 applied recursively and then the output of all the fields 151 in the list is inserted according to format-string. 152 153 Note that the author string should not contain whitespace 154 \(put it in the neighbouring fields instead)." 155 156 :type `(alist :key-type (choice ,notmuch-tree--field-names 157 (alist :key-type ,notmuch-tree--field-names 158 :value-type (string :tag "Format"))) 159 :value-type (string :tag "Format")) 160 :group 'notmuch-tree) 161 162 (defun notmuch-tree-result-format () 163 (if notmuch-tree-unthreaded 164 notmuch-unthreaded-result-format 165 notmuch-tree-result-format)) 166 167 ;;; Faces 168 ;;;; Faces for messages that match the query 169 170 (defface notmuch-tree-match-face 171 '((t :inherit default)) 172 "Default face used in tree mode face for matching messages" 173 :group 'notmuch-tree 174 :group 'notmuch-faces) 175 176 (defface notmuch-tree-match-date-face 177 nil 178 "Face used in tree mode for the date in messages matching the query." 179 :group 'notmuch-tree 180 :group 'notmuch-faces) 181 182 (defface notmuch-tree-match-author-face 183 '((((class color) 184 (background dark)) 185 (:foreground "OliveDrab1")) 186 (((class color) 187 (background light)) 188 (:foreground "dark blue")) 189 (t 190 (:bold t))) 191 "Face used in tree mode for the author in messages matching the query." 192 :group 'notmuch-tree 193 :group 'notmuch-faces) 194 195 (defface notmuch-tree-match-subject-face 196 nil 197 "Face used in tree mode for the subject in messages matching the query." 198 :group 'notmuch-tree 199 :group 'notmuch-faces) 200 201 (defface notmuch-tree-match-tree-face 202 nil 203 "Face used in tree mode for the thread tree block graphics in 204 messages matching the query." 205 :group 'notmuch-tree 206 :group 'notmuch-faces) 207 208 (defface notmuch-tree-match-tag-face 209 '((((class color) 210 (background dark)) 211 (:foreground "OliveDrab1")) 212 (((class color) 213 (background light)) 214 (:foreground "navy blue" :bold t)) 215 (t 216 (:bold t))) 217 "Face used in tree mode for tags in messages matching the query." 218 :group 'notmuch-tree 219 :group 'notmuch-faces) 220 221 ;;;; Faces for messages that do not match the query 222 223 (defface notmuch-tree-no-match-face 224 '((t (:foreground "gray"))) 225 "Default face used in tree mode face for non-matching messages." 226 :group 'notmuch-tree 227 :group 'notmuch-faces) 228 229 (defface notmuch-tree-no-match-date-face 230 nil 231 "Face used in tree mode for non-matching dates." 232 :group 'notmuch-tree 233 :group 'notmuch-faces) 234 235 (defface notmuch-tree-no-match-subject-face 236 nil 237 "Face used in tree mode for non-matching subjects." 238 :group 'notmuch-tree 239 :group 'notmuch-faces) 240 241 (defface notmuch-tree-no-match-tree-face 242 nil 243 "Face used in tree mode for the thread tree block graphics in 244 messages matching the query." 245 :group 'notmuch-tree 246 :group 'notmuch-faces) 247 248 (defface notmuch-tree-no-match-author-face 249 nil 250 "Face used in tree mode for non-matching authors." 251 :group 'notmuch-tree 252 :group 'notmuch-faces) 253 254 (defface notmuch-tree-no-match-tag-face 255 nil 256 "Face used in tree mode face for non-matching tags." 257 :group 'notmuch-tree 258 :group 'notmuch-faces) 259 260 ;;; Variables 261 262 (defvar-local notmuch-tree-previous-subject 263 "The subject of the most recent result shown during the async display.") 264 265 (defvar-local notmuch-tree-basic-query nil 266 "A buffer local copy of argument query to the function notmuch-tree.") 267 268 (defvar-local notmuch-tree-query-context nil 269 "A buffer local copy of argument query-context to the function notmuch-tree.") 270 271 (defvar-local notmuch-tree-target-msg nil 272 "A buffer local copy of argument target to the function notmuch-tree.") 273 274 (defvar-local notmuch-tree-open-target nil 275 "A buffer local copy of argument open-target to the function notmuch-tree.") 276 277 (defvar-local notmuch-tree-parent-buffer nil) 278 279 (defvar-local notmuch-tree-message-window nil 280 "The window of the message pane. 281 282 It is set in both the tree buffer and the child show buffer. It 283 is used to try and close the message pane when quitting tree view 284 or the child show buffer.") 285 (put 'notmuch-tree-message-window 'permanent-local t) 286 287 (defvar-local notmuch-tree-message-buffer nil 288 "The buffer name of the show buffer in the message pane. 289 290 This is used to try and make sure we don't close the message pane 291 if the user has loaded a different buffer in that window.") 292 (put 'notmuch-tree-message-buffer 'permanent-local t) 293 294 ;;; Tree wrapper commands 295 296 (defmacro notmuch-tree--define-do-in-message-window (name cmd) 297 "Define NAME as a command that calls CMD interactively in the message window. 298 If the message pane is closed then this command does nothing. 299 Avoid using this macro in new code; it will be removed." 300 `(defun ,name () 301 ,(concat "(In message window) " (documentation cmd t)) 302 (interactive) 303 (when (window-live-p notmuch-tree-message-window) 304 (with-selected-window notmuch-tree-message-window 305 (call-interactively #',cmd))))) 306 307 (notmuch-tree--define-do-in-message-window 308 notmuch-tree-previous-message-button 309 notmuch-show-previous-button) 310 (notmuch-tree--define-do-in-message-window 311 notmuch-tree-next-message-button 312 notmuch-show-next-button) 313 (notmuch-tree--define-do-in-message-window 314 notmuch-tree-toggle-message-process-crypto 315 notmuch-show-toggle-process-crypto) 316 317 (defun notmuch-tree--message-process-crypto () 318 "Return value of `notmuch-show-process-crypto' in the message window. 319 If that window isn't alive, then return the current value. 320 Avoid using this function in new code; it will be removed." 321 (if (window-live-p notmuch-tree-message-window) 322 (with-selected-window notmuch-tree-message-window 323 notmuch-show-process-crypto) 324 notmuch-show-process-crypto)) 325 326 (defmacro notmuch-tree--define-close-message-window-and (name cmd) 327 "Define NAME as a variant of CMD. 328 329 NAME determines the value of `notmuch-show-process-crypto' in the 330 message window, closes the window, and then call CMD interactively 331 with that value let-bound. If the message window does not exist, 332 then NAME behaves like CMD." 333 `(defun ,name () 334 ,(concat "(Close message pane and) " (documentation cmd t)) 335 (interactive) 336 (let ((notmuch-show-process-crypto 337 (notmuch-tree--message-process-crypto))) 338 (notmuch-tree-close-message-window) 339 (call-interactively #',cmd)))) 340 341 (notmuch-tree--define-close-message-window-and 342 notmuch-tree-help 343 notmuch-help) 344 (notmuch-tree--define-close-message-window-and 345 notmuch-tree-new-mail 346 notmuch-mua-new-mail) 347 (notmuch-tree--define-close-message-window-and 348 notmuch-tree-jump-search 349 notmuch-jump-search) 350 (notmuch-tree--define-close-message-window-and 351 notmuch-tree-forward-message 352 notmuch-show-forward-message) 353 (notmuch-tree--define-close-message-window-and 354 notmuch-tree-reply-sender 355 notmuch-show-reply-sender) 356 (notmuch-tree--define-close-message-window-and 357 notmuch-tree-reply 358 notmuch-show-reply) 359 (notmuch-tree--define-close-message-window-and 360 notmuch-tree-view-raw-message 361 notmuch-show-view-raw-message) 362 363 ;;; Keymap 364 365 (defvar notmuch-tree-mode-map 366 (let ((map (make-sparse-keymap))) 367 (set-keymap-parent map notmuch-common-keymap) 368 ;; These bindings shadow common bindings with variants 369 ;; that additionally close the message window. 370 (define-key map [remap notmuch-bury-or-kill-this-buffer] 'notmuch-tree-quit) 371 (define-key map [remap notmuch-search] 'notmuch-tree-to-search) 372 (define-key map [remap notmuch-help] 'notmuch-tree-help) 373 (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail) 374 (define-key map [remap notmuch-jump-search] 'notmuch-tree-jump-search) 375 376 (define-key map "o" 'notmuch-tree-toggle-order) 377 (define-key map "S" 'notmuch-search-from-tree-current-query) 378 (define-key map "U" 'notmuch-unthreaded-from-tree-current-query) 379 (define-key map "Z" 'notmuch-tree-from-unthreaded-current-query) 380 381 ;; these use notmuch-show functions directly 382 (define-key map "|" 'notmuch-show-pipe-message) 383 (define-key map "w" 'notmuch-show-save-attachments) 384 (define-key map "v" 'notmuch-show-view-all-mime-parts) 385 (define-key map "c" 'notmuch-show-stash-map) 386 (define-key map "b" 'notmuch-show-resend-message) 387 388 ;; these apply to the message pane 389 (define-key map (kbd "M-TAB") 'notmuch-tree-previous-message-button) 390 (define-key map (kbd "<backtab>") 'notmuch-tree-previous-message-button) 391 (define-key map (kbd "TAB") 'notmuch-tree-next-message-button) 392 (define-key map "$" 'notmuch-tree-toggle-message-process-crypto) 393 394 ;; bindings from show (or elsewhere) but we close the message pane first. 395 (define-key map "f" 'notmuch-tree-forward-message) 396 (define-key map "r" 'notmuch-tree-reply-sender) 397 (define-key map "R" 'notmuch-tree-reply) 398 (define-key map "V" 'notmuch-tree-view-raw-message) 399 (define-key map "l" 'notmuch-tree-filter) 400 (define-key map "t" 'notmuch-tree-filter-by-tag) 401 (define-key map "E" 'notmuch-tree-edit-search) 402 403 ;; The main tree view bindings 404 (define-key map (kbd "RET") 'notmuch-tree-show-message) 405 (define-key map [mouse-1] 'notmuch-tree-show-message) 406 (define-key map "x" 'notmuch-tree-archive-message-then-next-or-exit) 407 (define-key map "X" 'notmuch-tree-archive-thread-then-exit) 408 (define-key map "A" 'notmuch-tree-archive-thread-then-next) 409 (define-key map "a" 'notmuch-tree-archive-message-then-next) 410 (define-key map "z" 'notmuch-tree-to-tree) 411 (define-key map "n" 'notmuch-tree-next-matching-message) 412 (define-key map "p" 'notmuch-tree-prev-matching-message) 413 (define-key map "N" 'notmuch-tree-next-message) 414 (define-key map "P" 'notmuch-tree-prev-message) 415 (define-key map (kbd "M-p") 'notmuch-tree-prev-thread) 416 (define-key map (kbd "M-n") 'notmuch-tree-next-thread) 417 (define-key map "k" 'notmuch-tag-jump) 418 (define-key map "-" 'notmuch-tree-remove-tag) 419 (define-key map "+" 'notmuch-tree-add-tag) 420 (define-key map "*" 'notmuch-tree-tag-thread) 421 (define-key map " " 'notmuch-tree-scroll-or-next) 422 (define-key map (kbd "DEL") 'notmuch-tree-scroll-message-window-back) 423 (define-key map "e" 'notmuch-tree-resume-message) 424 map) 425 "Keymap for \"notmuch tree\" buffers.") 426 427 ;;; Message properties 428 429 (defun notmuch-tree-get-message-properties () 430 "Return the properties of the current message as a plist. 431 432 Some useful entries are: 433 :headers - Property list containing the headers :Date, :Subject, :From, etc. 434 :tags - Tags for this message." 435 (save-excursion 436 (beginning-of-line) 437 (get-text-property (point) :notmuch-message-properties))) 438 439 (defun notmuch-tree-set-message-properties (props) 440 (save-excursion 441 (beginning-of-line) 442 (put-text-property (point) 443 (+ (point) 1) 444 :notmuch-message-properties props))) 445 446 (defun notmuch-tree-set-prop (prop val &optional props) 447 (let ((inhibit-read-only t) 448 (props (or props 449 (notmuch-tree-get-message-properties)))) 450 (plist-put props prop val) 451 (notmuch-tree-set-message-properties props))) 452 453 (defun notmuch-tree-get-prop (prop &optional props) 454 (plist-get (or props (notmuch-tree-get-message-properties)) 455 prop)) 456 457 (defun notmuch-tree-set-tags (tags) 458 "Set the tags of the current message." 459 (notmuch-tree-set-prop :tags tags)) 460 461 (defun notmuch-tree-get-tags () 462 "Return the tags of the current message." 463 (notmuch-tree-get-prop :tags)) 464 465 (defun notmuch-tree-get-message-id (&optional bare) 466 "Return the message id of the current message." 467 (let ((id (notmuch-tree-get-prop :id))) 468 (if id 469 (if bare 470 id 471 (notmuch-id-to-query id)) 472 nil))) 473 474 (defun notmuch-tree-get-match () 475 "Return whether the current message is a match." 476 (notmuch-tree-get-prop :match)) 477 478 ;;; Update display 479 480 (defun notmuch-tree-refresh-result () 481 "Redisplay the current message line. 482 483 This redisplays the current line based on the messages 484 properties (as they are now). This is used when tags are 485 updated." 486 (let ((init-point (point)) 487 (end (line-end-position)) 488 (msg (notmuch-tree-get-message-properties)) 489 (inhibit-read-only t)) 490 (beginning-of-line) 491 ;; This is a little tricky: we override 492 ;; notmuch-tree-previous-subject to get the decision between 493 ;; ... and a subject right and it stops notmuch-tree-insert-msg 494 ;; from overwriting the buffer local copy of 495 ;; notmuch-tree-previous-subject if this is called while the 496 ;; buffer is displaying. 497 (let ((notmuch-tree-previous-subject 498 (notmuch-tree-get-prop :previous-subject))) 499 (delete-region (point) (1+ (line-end-position))) 500 (notmuch-tree-insert-msg msg)) 501 (let ((new-end (line-end-position))) 502 (goto-char (if (= init-point end) 503 new-end 504 (min init-point (- new-end 1))))))) 505 506 (defun notmuch-tree-tag-update-display (&optional tag-changes) 507 "Update display for TAG-CHANGES to current message. 508 509 Updates the message in the message pane if appropriate, but does 510 NOT change the database." 511 (let* ((current-tags (notmuch-tree-get-tags)) 512 (new-tags (notmuch-update-tags current-tags tag-changes)) 513 (tree-msg-id (notmuch-tree-get-message-id))) 514 (unless (equal current-tags new-tags) 515 (notmuch-tree-set-tags new-tags) 516 (notmuch-tree-refresh-result) 517 (when (window-live-p notmuch-tree-message-window) 518 (with-selected-window notmuch-tree-message-window 519 (when (string= tree-msg-id (notmuch-show-get-message-id)) 520 (notmuch-show-update-tags new-tags))))))) 521 522 ;;; Commands (and some helper functions used by them) 523 524 (defun notmuch-tree-tag (tag-changes) 525 "Change tags for the current message." 526 (interactive 527 (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message"))) 528 (notmuch-tag (notmuch-tree-get-message-id) tag-changes) 529 (notmuch-tree-tag-update-display tag-changes)) 530 531 (defun notmuch-tree-add-tag (tag-changes) 532 "Same as `notmuch-tree-tag' but sets initial input to '+'." 533 (interactive 534 (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+"))) 535 (notmuch-tree-tag tag-changes)) 536 537 (defun notmuch-tree-remove-tag (tag-changes) 538 "Same as `notmuch-tree-tag' but sets initial input to '-'." 539 (interactive 540 (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-"))) 541 (notmuch-tree-tag tag-changes)) 542 543 (defun notmuch-tree-resume-message () 544 "Resume EDITING the current draft message." 545 (interactive) 546 (notmuch-tree-close-message-window) 547 (let ((id (notmuch-tree-get-message-id))) 548 (if id 549 (notmuch-draft-resume id) 550 (message "No message to resume!")))) 551 552 ;; The next two functions close the message window before calling 553 ;; notmuch-search or notmuch-tree but they do so after the user has 554 ;; entered the query (in case the user was basing the query on 555 ;; something in the message window). 556 557 (defun notmuch-tree-to-search () 558 "Run \"notmuch search\" with the given `query' and display results." 559 (interactive) 560 (let ((query (notmuch-read-query "Notmuch search: "))) 561 (notmuch-tree-close-message-window) 562 (notmuch-search query))) 563 564 (defun notmuch-tree-to-tree () 565 "Run a query and display results in tree view." 566 (interactive) 567 (let ((query (notmuch-read-query "Notmuch tree view search: "))) 568 (notmuch-tree-close-message-window) 569 (notmuch-tree query))) 570 571 (defun notmuch-tree-archive-thread-then-next () 572 "Archive all messages in the current buffer, then show next thread from search." 573 (interactive) 574 (notmuch-tree-archive-thread) 575 (notmuch-tree-next-thread)) 576 577 (defun notmuch-unthreaded-from-tree-current-query () 578 "Switch from tree view to unthreaded view." 579 (interactive) 580 (unless notmuch-tree-unthreaded 581 (notmuch-tree-refresh-view 'unthreaded))) 582 583 (defun notmuch-tree-from-unthreaded-current-query () 584 "Switch from unthreaded view to tree view." 585 (interactive) 586 (when notmuch-tree-unthreaded 587 (notmuch-tree-refresh-view 'tree))) 588 589 (defun notmuch-search-from-tree-current-query () 590 "Call notmuch search with the current query." 591 (interactive) 592 (notmuch-tree-close-message-window) 593 (notmuch-search (notmuch-tree-get-query))) 594 595 (defun notmuch-tree-message-window-kill-hook () 596 "Close the message pane when exiting the show buffer." 597 (let ((buffer (current-buffer))) 598 (when (and (window-live-p notmuch-tree-message-window) 599 (eq (window-buffer notmuch-tree-message-window) buffer)) 600 ;; We could check whether this is the only window in its frame, 601 ;; but simply ignoring the error that is thrown otherwise is 602 ;; what we had to do for Emacs 24 and we stick to that because 603 ;; it is still the simplest approach. 604 (ignore-errors 605 (delete-window notmuch-tree-message-window))))) 606 607 (defun notmuch-tree-command-hook () 608 (when (eq major-mode 'notmuch-tree-mode) 609 ;; We just run the notmuch-show-command-hook on the message pane. 610 (when (buffer-live-p notmuch-tree-message-buffer) 611 (with-current-buffer notmuch-tree-message-buffer 612 (notmuch-show-command-hook))))) 613 614 (defun notmuch-tree-show-message-in () 615 "Show the current message (in split-pane)." 616 (interactive) 617 (let ((id (notmuch-tree-get-message-id)) 618 (inhibit-read-only t) 619 buffer) 620 (when id 621 ;; We close and reopen the window to kill off un-needed buffers 622 ;; this might cause flickering but seems ok. 623 (notmuch-tree-close-message-window) 624 (setq notmuch-tree-message-window 625 (split-window-vertically (/ (window-height) 4))) 626 (with-selected-window notmuch-tree-message-window 627 (let (;; Since we are only displaying one message do not indent. 628 (notmuch-show-indent-messages-width 0) 629 (notmuch-show-single-message t) 630 ;; Ensure that `pop-to-buffer-same-window' uses the 631 ;; window we want it to use. 632 (display-buffer-overriding-action 633 '((display-buffer-same-window) 634 (inhibit-same-window . nil)))) 635 (setq buffer (notmuch-show id)))) 636 ;; We need the `let' as notmuch-tree-message-window is buffer local. 637 (let ((window notmuch-tree-message-window)) 638 (with-current-buffer buffer 639 (setq notmuch-tree-message-window window) 640 (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook))) 641 (when notmuch-show-mark-read-tags 642 (notmuch-tree-tag-update-display notmuch-show-mark-read-tags)) 643 (setq notmuch-tree-message-buffer buffer)))) 644 645 (defun notmuch-tree-show-message-out () 646 "Show the current message (in whole window)." 647 (interactive) 648 (let ((id (notmuch-tree-get-message-id)) 649 (inhibit-read-only t)) 650 (when id 651 ;; We close the window to kill off un-needed buffers. 652 (notmuch-tree-close-message-window) 653 ;; n-s-s-m is buffer local, so use inner let. 654 (let ((notmuch-show-single-message t)) 655 (notmuch-show id))))) 656 657 (defun notmuch-tree-show-message (arg) 658 "Show the current message. 659 660 Shows in split pane or whole window according to value of 661 `notmuch-tree-show-out'. A prefix argument reverses the choice." 662 (interactive "P") 663 (if (or (and (notmuch-tree-show-out) (not arg)) 664 (and (not (notmuch-tree-show-out)) arg)) 665 (notmuch-tree-show-message-out) 666 (notmuch-tree-show-message-in))) 667 668 (defun notmuch-tree-scroll-message-window () 669 "Scroll the message window (if it exists)." 670 (interactive) 671 (when (window-live-p notmuch-tree-message-window) 672 (with-selected-window notmuch-tree-message-window 673 (if (pos-visible-in-window-p (point-max)) 674 t 675 (scroll-up))))) 676 677 (defun notmuch-tree-scroll-message-window-back () 678 "Scroll the message window back (if it exists)." 679 (interactive) 680 (when (window-live-p notmuch-tree-message-window) 681 (with-selected-window notmuch-tree-message-window 682 (if (pos-visible-in-window-p (point-min)) 683 t 684 (scroll-down))))) 685 686 (defun notmuch-tree-scroll-or-next () 687 "Scroll the message window. 688 If it at end go to next message." 689 (interactive) 690 (when (notmuch-tree-scroll-message-window) 691 (notmuch-tree-next-matching-message))) 692 693 (defun notmuch-tree-quit (&optional kill-both) 694 "Close the split view or exit tree." 695 (interactive "P") 696 (when (or (not (notmuch-tree-close-message-window)) kill-both) 697 (kill-buffer (current-buffer)))) 698 699 (defun notmuch-tree-close-message-window () 700 "Close the message-window. Return t if close succeeds." 701 (interactive) 702 (when (and (window-live-p notmuch-tree-message-window) 703 (eq (window-buffer notmuch-tree-message-window) 704 notmuch-tree-message-buffer)) 705 (delete-window notmuch-tree-message-window) 706 (unless (get-buffer-window-list notmuch-tree-message-buffer) 707 (kill-buffer notmuch-tree-message-buffer)) 708 t)) 709 710 (defun notmuch-tree-archive-message (&optional unarchive) 711 "Archive the current message. 712 713 Archive the current message by applying the tag changes in 714 `notmuch-archive-tags' to it. If a prefix argument is given, the 715 message will be \"unarchived\", i.e. the tag changes in 716 `notmuch-archive-tags' will be reversed." 717 (interactive "P") 718 (when notmuch-archive-tags 719 (notmuch-tree-tag 720 (notmuch-tag-change-list notmuch-archive-tags unarchive)))) 721 722 (defun notmuch-tree-archive-message-then-next (&optional unarchive) 723 "Archive the current message and move to next matching message." 724 (interactive "P") 725 (notmuch-tree-archive-message unarchive) 726 (notmuch-tree-next-matching-message)) 727 728 (defun notmuch-tree-archive-thread-then-exit () 729 "Archive all messages in the current buffer, then exit notmuch-tree." 730 (interactive) 731 (notmuch-tree-archive-thread) 732 (notmuch-tree-quit t)) 733 734 (defun notmuch-tree-archive-message-then-next-or-exit () 735 "Archive current message, then show next open message in current thread. 736 737 If at the last open message in the current thread, then exit back 738 to search results." 739 (interactive) 740 (notmuch-tree-archive-message) 741 (notmuch-tree-next-matching-message t)) 742 743 (defun notmuch-tree-next-message () 744 "Move to next message." 745 (interactive) 746 (forward-line) 747 (when (window-live-p notmuch-tree-message-window) 748 (notmuch-tree-show-message-in))) 749 750 (defun notmuch-tree-prev-message () 751 "Move to previous message." 752 (interactive) 753 (forward-line -1) 754 (when (window-live-p notmuch-tree-message-window) 755 (notmuch-tree-show-message-in))) 756 757 (defun notmuch-tree-goto-matching-message (&optional prev) 758 "Move to the next or previous matching message. 759 760 Returns t if there was a next matching message in the thread to show, 761 nil otherwise." 762 (let ((dir (if prev -1 nil)) 763 (eobfn (if prev #'bobp #'eobp))) 764 (while (and (not (funcall eobfn)) 765 (not (notmuch-tree-get-match))) 766 (forward-line dir)) 767 (not (funcall eobfn)))) 768 769 (defun notmuch-tree-matching-message (&optional prev pop-at-end) 770 "Move to the next or previous matching message." 771 (interactive "P") 772 (forward-line (if prev -1 nil)) 773 (if (and (not (notmuch-tree-goto-matching-message prev)) pop-at-end) 774 (notmuch-tree-quit pop-at-end) 775 (when (window-live-p notmuch-tree-message-window) 776 (notmuch-tree-show-message-in)))) 777 778 (defun notmuch-tree-prev-matching-message (&optional pop-at-end) 779 "Move to previous matching message." 780 (interactive "P") 781 (notmuch-tree-matching-message t pop-at-end)) 782 783 (defun notmuch-tree-next-matching-message (&optional pop-at-end) 784 "Move to next matching message." 785 (interactive "P") 786 (notmuch-tree-matching-message nil pop-at-end)) 787 788 (defun notmuch-tree-refresh-view (&optional view) 789 "Refresh view." 790 (interactive) 791 (when (get-buffer-process (current-buffer)) 792 (error "notmuch tree process already running for current buffer")) 793 (let ((inhibit-read-only t) 794 (basic-query notmuch-tree-basic-query) 795 (unthreaded (cond ((eq view 'unthreaded) t) 796 ((eq view 'tree) nil) 797 (t notmuch-tree-unthreaded))) 798 (query-context notmuch-tree-query-context) 799 (target (notmuch-tree-get-message-id))) 800 (erase-buffer) 801 (notmuch-tree-worker basic-query 802 query-context 803 target 804 nil 805 unthreaded 806 notmuch-search-oldest-first))) 807 808 (defun notmuch-tree-thread-top () 809 (when (notmuch-tree-get-message-properties) 810 (while (not (or (notmuch-tree-get-prop :first) (eobp))) 811 (forward-line -1)))) 812 813 (defun notmuch-tree-prev-thread-in-tree () 814 "Move to the previous thread in the current tree" 815 (interactive) 816 (forward-line -1) 817 (notmuch-tree-thread-top) 818 (not (bobp))) 819 820 (defun notmuch-tree-next-thread-in-tree () 821 "Get the next thread in the current tree. Returns t if a thread was 822 found or nil if not." 823 (interactive) 824 (forward-line 1) 825 (while (not (or (notmuch-tree-get-prop :first) (eobp))) 826 (forward-line 1)) 827 (not (eobp))) 828 829 (defun notmuch-tree-next-thread-from-search (&optional previous) 830 "Move to the next thread in the parent search results, if any. 831 832 If PREVIOUS is non-nil, move to the previous item in the 833 search results instead." 834 (interactive "P") 835 (let ((parent-buffer notmuch-tree-parent-buffer)) 836 (notmuch-tree-quit t) 837 (when (buffer-live-p parent-buffer) 838 (switch-to-buffer parent-buffer) 839 (if previous 840 (notmuch-search-previous-thread) 841 (notmuch-search-next-thread)) 842 (notmuch-tree-from-search-thread)))) 843 844 (defun notmuch-tree-next-thread (&optional previous) 845 "Move to the next thread in the current tree or parent search results. 846 847 If PREVIOUS is non-nil, move to the previous thread in the tree or 848 search results instead." 849 (interactive) 850 (unless (if previous (notmuch-tree-prev-thread-in-tree) 851 (notmuch-tree-next-thread-in-tree)) 852 (notmuch-tree-next-thread-from-search previous))) 853 854 (defun notmuch-tree-prev-thread () 855 "Move to the previous thread in the current tree or parent search results." 856 (interactive) 857 (notmuch-tree-next-thread t)) 858 859 (defun notmuch-tree-thread-mapcar (function) 860 "Call FUNCTION for each message in the current thread. 861 FUNCTION is called for side effects only." 862 (save-excursion 863 (notmuch-tree-thread-top) 864 (cl-loop collect (funcall function) 865 do (forward-line) 866 while (and (notmuch-tree-get-message-properties) 867 (not (notmuch-tree-get-prop :first)))))) 868 869 (defun notmuch-tree-get-messages-ids-thread-search () 870 "Return a search string for all message ids of messages in the current thread." 871 (mapconcat 'identity 872 (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id) 873 " or ")) 874 875 (defun notmuch-tree-tag-thread (tag-changes) 876 "Tag all messages in the current thread." 877 (interactive 878 (let ((tags (apply #'append (notmuch-tree-thread-mapcar 879 (lambda () (notmuch-tree-get-tags)))))) 880 (list (notmuch-read-tag-changes tags "Tag thread")))) 881 (when (notmuch-tree-get-message-properties) 882 (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes) 883 (notmuch-tree-thread-mapcar 884 (lambda () (notmuch-tree-tag-update-display tag-changes))))) 885 886 (defun notmuch-tree-archive-thread (&optional unarchive) 887 "Archive each message in thread. 888 889 Archive each message currently shown by applying the tag changes 890 in `notmuch-archive-tags' to each. If a prefix argument is given, 891 the messages will be \"unarchived\", i.e. the tag changes in 892 `notmuch-archive-tags' will be reversed. 893 894 Note: This command is safe from any race condition of new messages 895 being delivered to the same thread. It does not archive the 896 entire thread, but only the messages shown in the current 897 buffer." 898 (interactive "P") 899 (when notmuch-archive-tags 900 (notmuch-tree-tag-thread 901 (notmuch-tag-change-list notmuch-archive-tags unarchive)))) 902 903 ;;; Functions for displaying the tree buffer itself 904 905 (defun notmuch-tree-clean-address (address) 906 "Try to clean a single email ADDRESS for display. Return 907 AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return 908 unchanged ADDRESS if parsing fails." 909 (let* ((clean-address (notmuch-clean-address address)) 910 (p-address (car clean-address)) 911 (p-name (cdr clean-address))) 912 913 ;; If we have a name return that otherwise return the address. 914 (or p-name p-address))) 915 916 (defun notmuch-tree-format-field (field format-string msg) 917 "Format a FIELD of MSG according to FORMAT-STRING and return string." 918 (let* ((headers (plist-get msg :headers)) 919 (match (plist-get msg :match))) 920 (cond 921 ((listp field) 922 (format format-string (notmuch-tree-format-field-list field msg))) 923 924 ((functionp field) 925 (funcall field format-string msg)) 926 927 ((string-equal field "date") 928 (let ((face (if match 929 'notmuch-tree-match-date-face 930 'notmuch-tree-no-match-date-face))) 931 (propertize (format format-string (plist-get msg :date_relative)) 932 'face face))) 933 934 ((string-equal field "tree") 935 (let ((tree-status (plist-get msg :tree-status)) 936 (face (if match 937 'notmuch-tree-match-tree-face 938 'notmuch-tree-no-match-tree-face))) 939 940 (propertize (format format-string 941 (mapconcat #'identity (reverse tree-status) "")) 942 'face face))) 943 944 ((string-equal field "subject") 945 (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject))) 946 (previous-subject notmuch-tree-previous-subject) 947 (face (if match 948 'notmuch-tree-match-subject-face 949 'notmuch-tree-no-match-subject-face))) 950 951 (setq notmuch-tree-previous-subject bare-subject) 952 (propertize (format format-string 953 (if (string= previous-subject bare-subject) 954 " ..." 955 bare-subject)) 956 'face face))) 957 958 ((string-equal field "authors") 959 (let ((author (notmuch-tree-clean-address (plist-get headers :From))) 960 (len (length (format format-string ""))) 961 (face (if match 962 'notmuch-tree-match-author-face 963 'notmuch-tree-no-match-author-face))) 964 (when (> (length author) len) 965 (setq author (substring author 0 len))) 966 (propertize (format format-string author) 'face face))) 967 968 ((string-equal field "tags") 969 (let ((tags (plist-get msg :tags)) 970 (orig-tags (plist-get msg :orig-tags)) 971 (face (if match 972 'notmuch-tree-match-tag-face 973 'notmuch-tree-no-match-tag-face))) 974 (format format-string (notmuch-tag-format-tags tags orig-tags face))))))) 975 976 (defun notmuch-tree-format-field-list (field-list msg) 977 "Format fields of MSG according to FIELD-LIST and return string." 978 (let ((face (if (plist-get msg :match) 979 'notmuch-tree-match-face 980 'notmuch-tree-no-match-face)) 981 (result-string)) 982 (dolist (spec field-list result-string) 983 (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg))) 984 (setq result-string (concat result-string field-string)))) 985 (notmuch-apply-face result-string face t))) 986 987 (defun notmuch-tree-insert-msg (msg) 988 "Insert the message MSG according to notmuch-tree-result-format." 989 ;; We need to save the previous subject as it will get overwritten 990 ;; by the insert-field calls. 991 (let ((previous-subject notmuch-tree-previous-subject)) 992 (insert (notmuch-tree-format-field-list (notmuch-tree-result-format) msg)) 993 (notmuch-tree-set-message-properties msg) 994 (notmuch-tree-set-prop :previous-subject previous-subject) 995 (insert "\n"))) 996 997 (defun notmuch-tree-goto-and-insert-msg (msg) 998 "Insert msg at the end of the buffer. Move point to msg if it is the target." 999 (save-excursion 1000 (goto-char (point-max)) 1001 (notmuch-tree-insert-msg msg)) 1002 (let ((msg-id (notmuch-id-to-query (plist-get msg :id))) 1003 (target notmuch-tree-target-msg)) 1004 (when (or (and (not target) (plist-get msg :match)) 1005 (string= msg-id target)) 1006 (setq notmuch-tree-target-msg "found") 1007 (goto-char (point-max)) 1008 (forward-line -1) 1009 (when notmuch-tree-open-target 1010 (notmuch-tree-show-message-in) 1011 (notmuch-tree-command-hook))))) 1012 1013 (defun notmuch-tree-insert-tree (tree depth tree-status first last) 1014 "Insert the message tree TREE at depth DEPTH in the current thread. 1015 1016 A message tree is another name for a single sub-thread: i.e., a 1017 message together with all its descendents." 1018 (let ((msg (car tree)) 1019 (replies (cadr tree)) 1020 ;; outline level, computed from the message's depth and 1021 ;; whether or not it's the first message in the tree. 1022 (level (1+ (if (and (eq 0 depth) (not first)) 1 depth)))) 1023 (cond 1024 ((and (< 0 depth) (not last)) 1025 (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status)) 1026 ((and (< 0 depth) last) 1027 (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) 1028 ((and (eq 0 depth) first last) 1029 (push (alist-get 'prefix notmuch-tree-thread-symbols) tree-status)) 1030 ((and (eq 0 depth) first (not last)) 1031 (push (alist-get 'top-tee notmuch-tree-thread-symbols) tree-status)) 1032 ((and (eq 0 depth) (not first) last) 1033 (push (alist-get 'bottom notmuch-tree-thread-symbols) tree-status)) 1034 ((and (eq 0 depth) (not first) (not last)) 1035 (push (alist-get 'vertical-tee notmuch-tree-thread-symbols) tree-status))) 1036 (push (concat (alist-get (if replies 'top-tee 'top) notmuch-tree-thread-symbols) 1037 (alist-get 'arrow notmuch-tree-thread-symbols)) 1038 tree-status) 1039 (setq msg (plist-put msg :first (and first (eq 0 depth)))) 1040 (setq msg (plist-put msg :tree-status tree-status)) 1041 (setq msg (plist-put msg :orig-tags (plist-get msg :tags))) 1042 (setq msg (plist-put msg :level level)) 1043 (notmuch-tree-goto-and-insert-msg msg) 1044 (pop tree-status) 1045 (pop tree-status) 1046 (if last 1047 (push " " tree-status) 1048 (push (alist-get 'vertical notmuch-tree-thread-symbols) tree-status)) 1049 (notmuch-tree-insert-thread replies (1+ depth) tree-status))) 1050 1051 (defun notmuch-tree-insert-thread (thread depth tree-status) 1052 "Insert the collection of sibling sub-threads THREAD at depth 1053 DEPTH in the current forest." 1054 (let ((n (length thread))) 1055 (cl-loop for tree in thread 1056 for count from 1 to n 1057 do (notmuch-tree-insert-tree tree depth tree-status 1058 (eq count 1) 1059 (eq count n))))) 1060 1061 (defun notmuch-tree-insert-forest-thread (forest-thread) 1062 "Insert a single complete thread." 1063 ;; Reset at the start of each main thread. 1064 (setq notmuch-tree-previous-subject nil) 1065 (notmuch-tree-insert-thread forest-thread 0 nil)) 1066 1067 (defun notmuch-tree-insert-forest (forest) 1068 "Insert a forest of threads. 1069 1070 This function inserts a collection of several complete threads as 1071 passed to it by notmuch-tree-process-filter." 1072 (mapc 'notmuch-tree-insert-forest-thread forest)) 1073 1074 (define-derived-mode notmuch-tree-mode fundamental-mode "notmuch-tree" 1075 "Major mode displaying messages (as opposed to threads) of a notmuch search. 1076 1077 This buffer contains the results of a \"notmuch tree\" of your 1078 email archives. Each line in the buffer represents a single 1079 message giving the relative date, the author, subject, and any 1080 tags. 1081 1082 Pressing \\[notmuch-tree-show-message] on any line displays that message. 1083 1084 Complete list of currently available key bindings: 1085 1086 \\{notmuch-tree-mode-map}" 1087 (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view) 1088 (hl-line-mode 1) 1089 (setq buffer-read-only t) 1090 (setq truncate-lines t) 1091 (when notmuch-tree-outline-enabled (notmuch-tree-outline-mode 1))) 1092 1093 (defvar notmuch-tree-process-exit-functions nil 1094 "Functions called when the process inserting a tree of results finishes. 1095 1096 Functions in this list are called with one argument, the process 1097 object, and with the tree results buffer as the current buffer.") 1098 1099 (defun notmuch-tree-process-sentinel (proc _msg) 1100 "Add a message to let user know when \"notmuch tree\" exits." 1101 (let ((buffer (process-buffer proc)) 1102 (status (process-status proc)) 1103 (exit-status (process-exit-status proc))) 1104 (when (memq status '(exit signal)) 1105 (kill-buffer (process-get proc 'parse-buf)) 1106 (when (buffer-live-p buffer) 1107 (with-current-buffer buffer 1108 (save-excursion 1109 (let ((inhibit-read-only t)) 1110 (goto-char (point-max)) 1111 (when (eq status 'signal) 1112 (insert "Incomplete search results (tree view process was killed).\n")) 1113 (when (eq status 'exit) 1114 (insert "End of search results.") 1115 (unless (= exit-status 0) 1116 (insert (format " (process returned %d)" exit-status))) 1117 (insert "\n")))) 1118 (run-hook-with-args 'notmuch-tree-process-exit-functions proc)))))) 1119 1120 (defun notmuch-tree-process-filter (proc string) 1121 "Process and filter the output of \"notmuch show\" for tree view." 1122 (let ((results-buf (process-buffer proc)) 1123 (parse-buf (process-get proc 'parse-buf)) 1124 (inhibit-read-only t)) 1125 (if (not (buffer-live-p results-buf)) 1126 (delete-process proc) 1127 (with-current-buffer parse-buf 1128 ;; Insert new data 1129 (save-excursion 1130 (goto-char (point-max)) 1131 (insert string)) 1132 (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread 1133 results-buf))))) 1134 1135 (defun notmuch-tree-worker (basic-query &optional query-context target 1136 open-target unthreaded oldest-first) 1137 "Insert the tree view of the search in the current buffer. 1138 1139 This is is a helper function for notmuch-tree. The arguments are 1140 the same as for the function notmuch-tree." 1141 (interactive) 1142 (notmuch-tree-mode) 1143 (add-hook 'post-command-hook #'notmuch-tree-command-hook t t) 1144 (setq notmuch-search-oldest-first oldest-first) 1145 (setq notmuch-tree-unthreaded unthreaded) 1146 (setq notmuch-tree-basic-query basic-query) 1147 (setq notmuch-tree-query-context (if (or (string= query-context "") 1148 (string= query-context "*")) 1149 nil 1150 query-context)) 1151 (setq notmuch-tree-target-msg target) 1152 (setq notmuch-tree-open-target open-target) 1153 ;; Set the default value for `notmuch-show-process-crypto' in this 1154 ;; buffer. Although we don't use this some of the functions we call 1155 ;; (such as reply) do. It is a buffer local variable so setting it 1156 ;; will not affect genuine show buffers. 1157 (setq notmuch-show-process-crypto notmuch-crypto-process-mime) 1158 (erase-buffer) 1159 (goto-char (point-min)) 1160 (let* ((search-args (concat basic-query 1161 (and query-context 1162 (concat " and (" query-context ")")))) 1163 (sort-arg (if oldest-first "--sort=oldest-first" "--sort=newest-first")) 1164 (message-arg (if unthreaded "--unthreaded" "--entire-thread"))) 1165 (when (equal (car (notmuch--process-lines notmuch-command "count" search-args)) "0") 1166 (setq search-args basic-query)) 1167 (notmuch-tag-clear-cache) 1168 (let ((proc (notmuch-start-notmuch 1169 "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel 1170 "show" "--body=false" "--format=sexp" "--format-version=5" 1171 sort-arg message-arg search-args)) 1172 ;; Use a scratch buffer to accumulate partial output. 1173 ;; This buffer will be killed by the sentinel, which 1174 ;; should be called no matter how the process dies. 1175 (parse-buf (generate-new-buffer " *notmuch tree parse*"))) 1176 (process-put proc 'parse-buf parse-buf) 1177 (set-process-filter proc 'notmuch-tree-process-filter) 1178 (set-process-query-on-exit-flag proc nil)))) 1179 1180 (defun notmuch-tree-get-query () 1181 "Return the current query in this tree buffer." 1182 (if notmuch-tree-query-context 1183 (concat notmuch-tree-basic-query 1184 " and (" 1185 notmuch-tree-query-context 1186 ")") 1187 notmuch-tree-basic-query)) 1188 1189 (defun notmuch-tree-toggle-order () 1190 "Toggle the current search order. 1191 1192 This command toggles the sort order for the current search. The 1193 default sort order is defined by `notmuch-search-oldest-first'." 1194 (interactive) 1195 (setq notmuch-search-oldest-first (not notmuch-search-oldest-first)) 1196 (notmuch-tree-refresh-view)) 1197 1198 (defun notmuch-tree (&optional query query-context target buffer-name 1199 open-target unthreaded parent-buffer oldest-first) 1200 "Display threads matching QUERY in tree view. 1201 1202 The arguments are: 1203 QUERY: the main query. This can be any query but in many cases will be 1204 a single thread. If nil this is read interactively from the minibuffer. 1205 QUERY-CONTEXT: is an additional term for the query. The query used 1206 is QUERY and QUERY-CONTEXT unless that does not match any messages 1207 in which case we fall back to just QUERY. 1208 TARGET: A message ID (with the id: prefix) that will be made 1209 current if it appears in the tree view results. 1210 BUFFER-NAME: the name of the buffer to display the tree view. If 1211 it is nil \"*notmuch-tree\" followed by QUERY is used. 1212 OPEN-TARGET: If TRUE open the target message in the message pane. 1213 UNTHREADED: If TRUE only show matching messages in an unthreaded view." 1214 (interactive) 1215 (unless query 1216 (setq query (notmuch-read-query (concat "Notmuch " 1217 (if unthreaded "unthreaded " "tree ") 1218 "view search: ")))) 1219 (let* ((name 1220 (or buffer-name 1221 (notmuch-search-buffer-title query 1222 (if unthreaded "unthreaded" "tree")))) 1223 (buffer (get-buffer-create (generate-new-buffer-name name))) 1224 (inhibit-read-only t)) 1225 (pop-to-buffer-same-window buffer)) 1226 ;; Don't track undo information for this buffer 1227 (setq buffer-undo-list t) 1228 (notmuch-tree-worker query query-context target open-target unthreaded oldest-first) 1229 (setq notmuch-tree-parent-buffer parent-buffer) 1230 (setq truncate-lines t)) 1231 1232 (defun notmuch-unthreaded (&optional query query-context target buffer-name 1233 open-target) 1234 "Display threads matching QUERY in unthreaded view. 1235 1236 See function NOTMUCH-TREE for documentation of the arguments" 1237 (interactive) 1238 (notmuch-tree query query-context target buffer-name open-target t)) 1239 1240 (defun notmuch-tree-filter (query) 1241 "Filter or LIMIT the current search results based on an additional query string. 1242 1243 Runs a new tree search matching only messages that match both the 1244 current search results AND the additional query string provided." 1245 (interactive (list (notmuch-read-query "Filter search: "))) 1246 (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto)) 1247 (grouped-query (notmuch-group-disjunctive-query-string query)) 1248 (grouped-original-query (notmuch-group-disjunctive-query-string 1249 (notmuch-tree-get-query)))) 1250 (notmuch-tree-close-message-window) 1251 (notmuch-tree (if (string= grouped-original-query "*") 1252 grouped-query 1253 (concat grouped-original-query " and " grouped-query))))) 1254 1255 (defun notmuch-tree-filter-by-tag (tag) 1256 "Filter the current search results based on a single TAG. 1257 1258 Run a new search matching only messages that match the current 1259 search results and that are also tagged with the given TAG." 1260 (interactive 1261 (list (notmuch-select-tag-with-completion "Filter by tag: " 1262 notmuch-tree-basic-query))) 1263 (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) 1264 (notmuch-tree-close-message-window) 1265 (notmuch-tree (concat notmuch-tree-basic-query " and tag:" tag) 1266 notmuch-tree-query-context 1267 nil 1268 nil 1269 nil 1270 notmuch-tree-unthreaded 1271 nil 1272 notmuch-search-oldest-first))) 1273 1274 (defun notmuch-tree-edit-search (query) 1275 "Edit the current search" 1276 (interactive (list (read-from-minibuffer "Edit search: " 1277 notmuch-tree-basic-query))) 1278 (let ((notmuch-show-process-crypto (notmuch-tree--message-process-crypto))) 1279 (notmuch-tree-close-message-window) 1280 (notmuch-tree query 1281 notmuch-tree-query-context 1282 nil 1283 nil 1284 nil 1285 notmuch-tree-unthreaded 1286 nil 1287 notmuch-search-oldest-first))) 1288 1289 ;;; Tree outline mode 1290 ;;;; Custom variables 1291 (defcustom notmuch-tree-outline-enabled nil 1292 "Whether to automatically activate `notmuch-tree-outline-mode' in tree views." 1293 :type 'boolean) 1294 1295 (defcustom notmuch-tree-outline-visibility 'hide-others 1296 "Default state of the forest outline for `notmuch-tree-outline-mode'. 1297 1298 This variable controls the state of a forest initially and after 1299 a movement command. If set to nil, all trees are displayed while 1300 the symbol hide-all indicates that all trees in the forest should 1301 be folded and hide-other that only the first one should be 1302 unfolded." 1303 :type '(choice (const :tag "Show all" nil) 1304 (const :tag "Hide others" hide-others) 1305 (const :tag "Hide all" hide-all))) 1306 1307 (defcustom notmuch-tree-outline-auto-close nil 1308 "Close message and tree windows when moving past the last message." 1309 :type 'boolean) 1310 1311 (defcustom notmuch-tree-outline-open-on-next nil 1312 "Open new messages under point if they are closed when moving to next one. 1313 1314 When this flag is set, using the command 1315 `notmuch-tree-outline-next' with point on a header for a new 1316 message that is not shown will open its `notmuch-show' buffer 1317 instead of moving point to next matching message." 1318 :type 'boolean) 1319 1320 ;;;; Helper functions 1321 (defsubst notmuch-tree-outline--pop-at-end (pop-at-end) 1322 (if notmuch-tree-outline-auto-close (not pop-at-end) pop-at-end)) 1323 1324 (defun notmuch-tree-outline--set-visibility () 1325 (when (and notmuch-tree-outline-mode (> (point-max) (point-min))) 1326 (cl-case notmuch-tree-outline-visibility 1327 (hide-others (notmuch-tree-outline-hide-others)) 1328 (hide-all (outline-hide-body))))) 1329 1330 (defun notmuch-tree-outline--on-exit (proc) 1331 (when (eq (process-status proc) 'exit) 1332 (notmuch-tree-outline--set-visibility))) 1333 1334 (add-hook 'notmuch-tree-process-exit-functions #'notmuch-tree-outline--on-exit) 1335 1336 (defsubst notmuch-tree-outline--level (&optional props) 1337 (or (plist-get (or props (notmuch-tree-get-message-properties)) :level) 0)) 1338 1339 (defsubst notmuch-tree-outline--message-open-p () 1340 (and (buffer-live-p notmuch-tree-message-buffer) 1341 (get-buffer-window notmuch-tree-message-buffer) 1342 (let ((id (notmuch-tree-get-message-id))) 1343 (and id 1344 (with-current-buffer notmuch-tree-message-buffer 1345 (string= (notmuch-show-get-message-id) id)))))) 1346 1347 (defsubst notmuch-tree-outline--at-original-match-p () 1348 (and (notmuch-tree-get-prop :match) 1349 (equal (notmuch-tree-get-prop :orig-tags) 1350 (notmuch-tree-get-prop :tags)))) 1351 1352 (defun notmuch-tree-outline--next (prev thread pop-at-end &optional open-new) 1353 (cond (thread 1354 (notmuch-tree-thread-top) 1355 (if prev 1356 (outline-backward-same-level 1) 1357 (outline-forward-same-level 1)) 1358 (when (> (notmuch-tree-outline--level) 0) (outline-show-branches)) 1359 (notmuch-tree-outline--next nil nil pop-at-end t)) 1360 ((and (or open-new notmuch-tree-outline-open-on-next) 1361 (notmuch-tree-outline--at-original-match-p) 1362 (not (notmuch-tree-outline--message-open-p))) 1363 (notmuch-tree-outline-hide-others t)) 1364 (t (outline-next-visible-heading (if prev -1 1)) 1365 (unless (notmuch-tree-get-prop :match) 1366 (notmuch-tree-matching-message prev pop-at-end)) 1367 (notmuch-tree-outline-hide-others t)))) 1368 1369 ;;;; User commands 1370 (defun notmuch-tree-outline-hide-others (&optional and-show) 1371 "Fold all threads except the one around point. 1372 If AND-SHOW is t, make the current message visible if it's not." 1373 (interactive) 1374 (save-excursion 1375 (while (and (not (bobp)) (> (notmuch-tree-outline--level) 1)) 1376 (outline-previous-heading)) 1377 (outline-hide-sublevels 1)) 1378 (when (> (notmuch-tree-outline--level) 0) 1379 (outline-show-subtree) 1380 (when and-show (notmuch-tree-show-message nil)))) 1381 1382 (defun notmuch-tree-outline-next (&optional pop-at-end) 1383 "Next matching message in a forest, taking care of thread visibility. 1384 A prefix argument reverses the meaning of `notmuch-tree-outline-auto-close'." 1385 (interactive "P") 1386 (let ((pop (notmuch-tree-outline--pop-at-end pop-at-end))) 1387 (if (null notmuch-tree-outline-visibility) 1388 (notmuch-tree-matching-message nil pop) 1389 (notmuch-tree-outline--next nil nil pop)))) 1390 1391 (defun notmuch-tree-outline-previous (&optional pop-at-end) 1392 "Previous matching message in forest, taking care of thread visibility. 1393 With prefix, quit the tree view if there is no previous message." 1394 (interactive "P") 1395 (if (null notmuch-tree-outline-visibility) 1396 (notmuch-tree-prev-matching-message pop-at-end) 1397 (notmuch-tree-outline--next t nil pop-at-end))) 1398 1399 (defun notmuch-tree-outline-next-thread () 1400 "Next matching thread in forest, taking care of thread visibility." 1401 (interactive) 1402 (if (null notmuch-tree-outline-visibility) 1403 (notmuch-tree-next-thread) 1404 (notmuch-tree-outline--next nil t nil))) 1405 1406 (defun notmuch-tree-outline-previous-thread () 1407 "Previous matching thread in forest, taking care of thread visibility." 1408 (interactive) 1409 (if (null notmuch-tree-outline-visibility) 1410 (notmuch-tree-prev-thread) 1411 (notmuch-tree-outline--next t t nil))) 1412 1413 ;;;; Mode definition 1414 (defvar notmuch-tree-outline-mode-lighter nil 1415 "The lighter mark for notmuch-tree-outline mode. 1416 Usually empty since outline-minor-mode's lighter will be active.") 1417 1418 (define-minor-mode notmuch-tree-outline-mode 1419 "Minor mode allowing message trees to be folded as outlines. 1420 1421 When this mode is set, each thread and subthread in the results 1422 list is treated as a foldable section, with its first message as 1423 its header. 1424 1425 The mode just makes available in the tree buffer all the 1426 keybindings in `outline-minor-mode', and binds the following 1427 additional keys: 1428 1429 \\{notmuch-tree-outline-mode-map} 1430 1431 The customizable variable `notmuch-tree-outline-visibility' 1432 controls how navigation in the buffer is affected by this mode: 1433 1434 - If it is set to nil, `notmuch-tree-outline-previous', 1435 `notmuch-tree-outline-next', and their thread counterparts 1436 behave just as the corresponding notmuch-tree navigation keys 1437 when this mode is not enabled. 1438 1439 - If, on the other hand, `notmuch-tree-outline-visibility' is 1440 set to a non-nil value, these commands hiding the outlines of 1441 the trees you are not reading as you move to new messages. 1442 1443 To enable notmuch-tree-outline-mode by default in all 1444 notmuch-tree buffers, just set 1445 `notmuch-tree-outline-mode-enabled' to t." 1446 :lighter notmuch-tree-outline-mode-lighter 1447 :keymap `((,(kbd "TAB") . outline-cycle) 1448 (,(kbd "M-TAB") . outline-cycle-buffer) 1449 ("n" . notmuch-tree-outline-next) 1450 ("p" . notmuch-tree-outline-previous) 1451 (,(kbd "M-n") . notmuch-tree-outline-next-thread) 1452 (,(kbd "M-p") . notmuch-tree-outline-previous-thread)) 1453 (outline-minor-mode notmuch-tree-outline-mode) 1454 (unless (derived-mode-p 'notmuch-tree-mode) 1455 (user-error "notmuch-tree-outline-mode is only meaningful for notmuch trees!")) 1456 (if notmuch-tree-outline-mode 1457 (progn (setq-local outline-regexp "^[^\n]+") 1458 (setq-local outline-level #'notmuch-tree-outline--level) 1459 (notmuch-tree-outline--set-visibility)) 1460 (setq-local outline-regexp (default-value 'outline-regexp)) 1461 (setq-local outline-level (default-value 'outline-level)))) 1462 1463 ;;; _ 1464 1465 (provide 'notmuch-tree) 1466 1467 ;;; notmuch-tree.el ends here