test: add (back) upgrade tests
[notmuch] / emacs / notmuch-tree.el
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-query)
31 (require 'notmuch-show)
32 (require 'notmuch-tag)
33 (require 'notmuch-parser)
34 (require 'notmuch-jump)
35
36 (declare-function notmuch-search "notmuch"
37                   (&optional query oldest-first target-thread target-line))
38 (declare-function notmuch-call-notmuch-process "notmuch" (&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 ;; the following variable is defined in notmuch.el
49 (defvar notmuch-search-query-string)
50
51 ;; this variable distinguishes the unthreaded display from the normal tree display
52 (defvar-local notmuch-tree-unthreaded nil
53   "A buffer local copy of argument unthreaded to the function notmuch-tree.")
54
55 ;;; Options
56
57 (defgroup notmuch-tree nil
58   "Showing message and thread structure."
59   :group 'notmuch)
60
61 (defcustom notmuch-tree-show-out nil
62   "View selected messages in new window rather than split-pane."
63   :type 'boolean
64   :group 'notmuch-tree)
65
66 (defcustom notmuch-unthreaded-show-out t
67   "View selected messages in new window rather than split-pane."
68   :type 'boolean
69   :group 'notmuch-tree)
70
71 (defun notmuch-tree-show-out ()
72   (if notmuch-tree-unthreaded
73       notmuch-unthreaded-show-out
74     notmuch-tree-show-out))
75
76 (defcustom notmuch-tree-result-format
77   `(("date" . "%12s  ")
78     ("authors" . "%-20s")
79     ((("tree" . "%s")("subject" . "%s")) ." %-54s ")
80     ("tags" . "(%s)"))
81   "Result formatting for tree view. Supported fields are: date,
82 authors, subject, tree, tags.  Tree means the thread tree
83 box graphics. The field may also be a list in which case
84 the formatting rules are applied recursively and then the
85 output of all the fields in the list is inserted
86 according to format-string.
87
88 Note the author string should not contain
89 whitespace (put it in the neighbouring fields instead).
90 For example:
91         (setq notmuch-tree-result-format \(\(\"authors\" . \"%-40s\"\)
92                                           \(\"subject\" . \"%s\"\)\)\)"
93   :type '(alist :key-type (string) :value-type (string))
94   :group 'notmuch-tree)
95
96 (defcustom notmuch-unthreaded-result-format
97   `(("date" . "%12s  ")
98     ("authors" . "%-20s")
99     ((("subject" . "%s")) ." %-54s ")
100     ("tags" . "(%s)"))
101   "Result formatting for unthreaded tree view. Supported fields are: date,
102 authors, subject, tree, tags.  Tree means the thread tree
103 box graphics. The field may also be a list in which case
104 the formatting rules are applied recursively and then the
105 output of all the fields in the list is inserted
106 according to format-string.
107
108 Note the author string should not contain
109 whitespace (put it in the neighbouring fields instead).
110 For example:
111         (setq notmuch-tree-result-format \(\(\"authors\" . \"%-40s\"\)
112                                           \(\"subject\" . \"%s\"\)\)\)"
113   :type '(alist :key-type (string) :value-type (string))
114   :group 'notmuch-tree)
115
116 (defun notmuch-tree-result-format ()
117   (if notmuch-tree-unthreaded
118       notmuch-unthreaded-result-format
119     notmuch-tree-result-format))
120
121 ;;; Faces
122 ;;;; Faces for messages that match the query
123
124 (defface notmuch-tree-match-face
125   '((t :inherit default))
126   "Default face used in tree mode face for matching messages"
127   :group 'notmuch-tree
128   :group 'notmuch-faces)
129
130 (defface notmuch-tree-match-date-face
131   nil
132   "Face used in tree mode for the date in messages matching the query."
133   :group 'notmuch-tree
134   :group 'notmuch-faces)
135
136 (defface notmuch-tree-match-author-face
137   '((((class color)
138       (background dark))
139      (:foreground "OliveDrab1"))
140     (((class color)
141       (background light))
142      (:foreground "dark blue"))
143     (t
144      (:bold t)))
145   "Face used in tree mode for the date in messages matching the query."
146   :group 'notmuch-tree
147   :group 'notmuch-faces)
148
149 (defface notmuch-tree-match-subject-face
150   nil
151   "Face used in tree mode for the subject in messages matching the query."
152   :group 'notmuch-tree
153   :group 'notmuch-faces)
154
155 (defface notmuch-tree-match-tree-face
156   nil
157   "Face used in tree mode for the thread tree block graphics in messages matching the query."
158   :group 'notmuch-tree
159   :group 'notmuch-faces)
160
161 (defface notmuch-tree-match-tag-face
162   '((((class color)
163       (background dark))
164      (:foreground "OliveDrab1"))
165     (((class color)
166       (background light))
167      (:foreground "navy blue" :bold t))
168     (t
169      (:bold t)))
170   "Face used in tree mode for tags in messages matching the query."
171   :group 'notmuch-tree
172   :group 'notmuch-faces)
173
174 ;;;; Faces for messages that do not match the query
175
176 (defface notmuch-tree-no-match-face
177   '((t (:foreground "gray")))
178   "Default face used in tree mode face for non-matching messages."
179   :group 'notmuch-tree
180   :group 'notmuch-faces)
181
182 (defface notmuch-tree-no-match-date-face
183   nil
184   "Face used in tree mode for non-matching dates."
185   :group 'notmuch-tree
186   :group 'notmuch-faces)
187
188 (defface notmuch-tree-no-match-subject-face
189   nil
190   "Face used in tree mode for non-matching subjects."
191   :group 'notmuch-tree
192   :group 'notmuch-faces)
193
194 (defface notmuch-tree-no-match-tree-face
195   nil
196   "Face used in tree mode for the thread tree block graphics in messages matching the query."
197   :group 'notmuch-tree
198   :group 'notmuch-faces)
199
200 (defface notmuch-tree-no-match-author-face
201   nil
202   "Face used in tree mode for the date in messages matching the query."
203   :group 'notmuch-tree
204   :group 'notmuch-faces)
205
206 (defface notmuch-tree-no-match-tag-face
207   nil
208   "Face used in tree mode face for non-matching tags."
209   :group 'notmuch-tree
210   :group 'notmuch-faces)
211
212 ;;; Variables
213
214 (defvar-local notmuch-tree-previous-subject
215   "The subject of the most recent result shown during the async display.")
216
217 (defvar-local notmuch-tree-basic-query nil
218   "A buffer local copy of argument query to the function notmuch-tree.")
219
220 (defvar-local notmuch-tree-query-context nil
221   "A buffer local copy of argument query-context to the function notmuch-tree.")
222
223 (defvar-local notmuch-tree-target-msg nil
224   "A buffer local copy of argument target to the function notmuch-tree.")
225
226 (defvar-local notmuch-tree-open-target nil
227   "A buffer local copy of argument open-target to the function notmuch-tree.")
228
229 (defvar-local notmuch-tree-parent-buffer nil)
230
231 (defvar-local notmuch-tree-message-window nil
232   "The window of the message pane.
233
234 It is set in both the tree buffer and the child show buffer. It
235 is used to try and close the message pane when quitting tree view
236 or the child show buffer.")
237 (put 'notmuch-tree-message-window 'permanent-local t)
238
239 (defvar-local notmuch-tree-message-buffer nil
240   "The buffer name of the show buffer in the message pane.
241
242 This is used to try and make sure we don't close the message pane
243 if the user has loaded a different buffer in that window.")
244 (put 'notmuch-tree-message-buffer 'permanent-local t)
245
246 ;;; Tree wrapper commands
247
248 (defmacro notmuch-tree--define-do-in-message-window (name cmd)
249   "Define NAME as a command that calls CMD interactively in the message window.
250 If the message pane is closed then this command does nothing.
251 Avoid using this macro in new code; it will be removed."
252   `(defun ,name ()
253      ,(concat "(In message window) " (documentation cmd t))
254      (interactive)
255      (when (window-live-p notmuch-tree-message-window)
256        (with-selected-window notmuch-tree-message-window
257          (call-interactively #',cmd)))))
258
259 (notmuch-tree--define-do-in-message-window
260  notmuch-tree-previous-message-button
261  notmuch-show-previous-button)
262 (notmuch-tree--define-do-in-message-window
263  notmuch-tree-next-message-button
264  notmuch-show-next-button)
265 (notmuch-tree--define-do-in-message-window
266  notmuch-tree-toggle-message-process-crypto
267  notmuch-show-toggle-process-crypto)
268
269 (defun notmuch-tree--message-process-crypto ()
270   "Return value of `notmuch-show-process-crypto' in the message window.
271 If that window isn't alive, then return the current value.
272 Avoid using this function in new code; it will be removed."
273   (if (window-live-p notmuch-tree-message-window)
274       (with-selected-window notmuch-tree-message-window
275         notmuch-show-process-crypto)
276     notmuch-show-process-crypto))
277
278 (defmacro notmuch-tree--define-close-message-window-and (name cmd)
279   "Define NAME as a variant of CMD.
280
281 NAME determines the value of `notmuch-show-process-crypto' in the
282 message window, closes the window, and then call CMD interactively
283 with that value let-bound.  If the message window does not exist,
284 then NAME behaves like CMD."
285   `(defun ,name ()
286      ,(concat "(Close message pane and) " (documentation cmd t))
287      (interactive)
288      (let ((notmuch-show-process-crypto
289             (notmuch-tree--message-process-crypto)))
290        (notmuch-tree-close-message-window)
291        (call-interactively #',cmd))))
292
293 (notmuch-tree--define-close-message-window-and
294  notmuch-tree-help
295  notmuch-help)
296 (notmuch-tree--define-close-message-window-and
297  notmuch-tree-new-mail
298  notmuch-mua-new-mail)
299 (notmuch-tree--define-close-message-window-and
300  notmuch-tree-jump-search
301  notmuch-jump-search)
302 (notmuch-tree--define-close-message-window-and
303  notmuch-tree-forward-message
304  notmuch-show-forward-message)
305 (notmuch-tree--define-close-message-window-and
306  notmuch-tree-reply-sender
307  notmuch-show-reply-sender)
308 (notmuch-tree--define-close-message-window-and
309  notmuch-tree-reply
310  notmuch-show-reply)
311 (notmuch-tree--define-close-message-window-and
312  notmuch-tree-view-raw-message
313  notmuch-show-view-raw-message)
314
315 ;;; Keymap
316
317 (defvar notmuch-tree-mode-map
318   (let ((map (make-sparse-keymap)))
319     (set-keymap-parent map notmuch-common-keymap)
320     ;; These bindings shadow common bindings with variants
321     ;; that additionally close the message window.
322     (define-key map [remap notmuch-bury-or-kill-this-buffer] 'notmuch-tree-quit)
323     (define-key map [remap notmuch-search]       'notmuch-tree-to-search)
324     (define-key map [remap notmuch-help]         'notmuch-tree-help)
325     (define-key map [remap notmuch-mua-new-mail] 'notmuch-tree-new-mail)
326     (define-key map [remap notmuch-jump-search]  'notmuch-tree-jump-search)
327
328     (define-key map "S" 'notmuch-search-from-tree-current-query)
329     (define-key map "U" 'notmuch-unthreaded-from-tree-current-query)
330     (define-key map "Z" 'notmuch-tree-from-unthreaded-current-query)
331
332     ;; these use notmuch-show functions directly
333     (define-key map "|" 'notmuch-show-pipe-message)
334     (define-key map "w" 'notmuch-show-save-attachments)
335     (define-key map "v" 'notmuch-show-view-all-mime-parts)
336     (define-key map "c" 'notmuch-show-stash-map)
337     (define-key map "b" 'notmuch-show-resend-message)
338
339     ;; these apply to the message pane
340     (define-key map (kbd "M-TAB")     'notmuch-tree-previous-message-button)
341     (define-key map (kbd "<backtab>") 'notmuch-tree-previous-message-button)
342     (define-key map (kbd "TAB")       'notmuch-tree-next-message-button)
343     (define-key map "$" 'notmuch-tree-toggle-message-process-crypto)
344
345     ;; bindings from show (or elsewhere) but we close the message pane first.
346     (define-key map "f" 'notmuch-tree-forward-message)
347     (define-key map "r" 'notmuch-tree-reply-sender)
348     (define-key map "R" 'notmuch-tree-reply)
349     (define-key map "V" 'notmuch-tree-view-raw-message)
350
351     ;; The main tree view bindings
352     (define-key map (kbd "RET") 'notmuch-tree-show-message)
353     (define-key map [mouse-1] 'notmuch-tree-show-message)
354     (define-key map "x" 'notmuch-tree-archive-message-then-next-or-exit)
355     (define-key map "X" 'notmuch-tree-archive-thread-then-exit)
356     (define-key map "A" 'notmuch-tree-archive-thread-then-next)
357     (define-key map "a" 'notmuch-tree-archive-message-then-next)
358     (define-key map "z" 'notmuch-tree-to-tree)
359     (define-key map "n" 'notmuch-tree-next-matching-message)
360     (define-key map "p" 'notmuch-tree-prev-matching-message)
361     (define-key map "N" 'notmuch-tree-next-message)
362     (define-key map "P" 'notmuch-tree-prev-message)
363     (define-key map (kbd "M-p") 'notmuch-tree-prev-thread)
364     (define-key map (kbd "M-n") 'notmuch-tree-next-thread)
365     (define-key map "k" 'notmuch-tag-jump)
366     (define-key map "-" 'notmuch-tree-remove-tag)
367     (define-key map "+" 'notmuch-tree-add-tag)
368     (define-key map "*" 'notmuch-tree-tag-thread)
369     (define-key map " " 'notmuch-tree-scroll-or-next)
370     (define-key map (kbd "DEL") 'notmuch-tree-scroll-message-window-back)
371     (define-key map "e" 'notmuch-tree-resume-message)
372     map)
373   "Keymap for \"notmuch tree\" buffers.")
374
375 ;;; Message properties
376
377 (defun notmuch-tree-get-message-properties ()
378   "Return the properties of the current message as a plist.
379
380 Some useful entries are:
381 :headers - Property list containing the headers :Date, :Subject, :From, etc.
382 :tags - Tags for this message."
383   (save-excursion
384     (beginning-of-line)
385     (get-text-property (point) :notmuch-message-properties)))
386
387 (defun notmuch-tree-set-message-properties (props)
388   (save-excursion
389     (beginning-of-line)
390     (put-text-property (point)
391                        (+ (point) 1)
392                        :notmuch-message-properties props)))
393
394 (defun notmuch-tree-set-prop (prop val &optional props)
395   (let ((inhibit-read-only t)
396         (props (or props
397                    (notmuch-tree-get-message-properties))))
398     (plist-put props prop val)
399     (notmuch-tree-set-message-properties props)))
400
401 (defun notmuch-tree-get-prop (prop &optional props)
402   (plist-get (or props (notmuch-tree-get-message-properties))
403              prop))
404
405 (defun notmuch-tree-set-tags (tags)
406   "Set the tags of the current message."
407   (notmuch-tree-set-prop :tags tags))
408
409 (defun notmuch-tree-get-tags ()
410   "Return the tags of the current message."
411   (notmuch-tree-get-prop :tags))
412
413 (defun notmuch-tree-get-message-id (&optional bare)
414   "Return the message id of the current message."
415   (let ((id (notmuch-tree-get-prop :id)))
416     (if id
417         (if bare
418             id
419           (notmuch-id-to-query id))
420       nil)))
421
422 (defun notmuch-tree-get-match ()
423   "Return whether the current message is a match."
424   (notmuch-tree-get-prop :match))
425
426 ;;; Update display
427
428 (defun notmuch-tree-refresh-result ()
429   "Redisplay the current message line.
430
431 This redisplays the current line based on the messages
432 properties (as they are now). This is used when tags are
433 updated."
434   (let ((init-point (point))
435         (end (line-end-position))
436         (msg (notmuch-tree-get-message-properties))
437         (inhibit-read-only t))
438     (beginning-of-line)
439     ;; This is a little tricky: we override
440     ;; notmuch-tree-previous-subject to get the decision between
441     ;; ... and a subject right and it stops notmuch-tree-insert-msg
442     ;; from overwriting the buffer local copy of
443     ;; notmuch-tree-previous-subject if this is called while the
444     ;; buffer is displaying.
445     (let ((notmuch-tree-previous-subject
446            (notmuch-tree-get-prop :previous-subject)))
447       (delete-region (point) (1+ (line-end-position)))
448       (notmuch-tree-insert-msg msg))
449     (let ((new-end (line-end-position)))
450       (goto-char (if (= init-point end)
451                      new-end
452                    (min init-point (- new-end 1)))))))
453
454 (defun notmuch-tree-tag-update-display (&optional tag-changes)
455   "Update display for TAG-CHANGES to current message.
456
457 Updates the message in the message pane if appropriate, but does
458 NOT change the database."
459   (let* ((current-tags (notmuch-tree-get-tags))
460          (new-tags (notmuch-update-tags current-tags tag-changes))
461          (tree-msg-id (notmuch-tree-get-message-id)))
462     (unless (equal current-tags new-tags)
463       (notmuch-tree-set-tags new-tags)
464       (notmuch-tree-refresh-result)
465       (when (window-live-p notmuch-tree-message-window)
466         (with-selected-window notmuch-tree-message-window
467           (when (string= tree-msg-id (notmuch-show-get-message-id))
468             (notmuch-show-update-tags new-tags)))))))
469
470 ;;; Commands (and some helper functions used by them)
471
472 (defun notmuch-tree-tag (tag-changes)
473   "Change tags for the current message."
474   (interactive
475    (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message")))
476   (notmuch-tag (notmuch-tree-get-message-id) tag-changes)
477   (notmuch-tree-tag-update-display tag-changes))
478
479 (defun notmuch-tree-add-tag (tag-changes)
480   "Same as `notmuch-tree-tag' but sets initial input to '+'."
481   (interactive
482    (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "+")))
483   (notmuch-tree-tag tag-changes))
484
485 (defun notmuch-tree-remove-tag (tag-changes)
486   "Same as `notmuch-tree-tag' but sets initial input to '-'."
487   (interactive
488    (list (notmuch-read-tag-changes (notmuch-tree-get-tags) "Tag message" "-")))
489   (notmuch-tree-tag tag-changes))
490
491 (defun notmuch-tree-resume-message ()
492   "Resume EDITING the current draft message."
493   (interactive)
494   (notmuch-tree-close-message-window)
495   (let ((id (notmuch-tree-get-message-id)))
496     (if id
497         (notmuch-draft-resume id)
498       (message "No message to resume!"))))
499
500 ;; The next two functions close the message window before calling
501 ;; notmuch-search or notmuch-tree but they do so after the user has
502 ;; entered the query (in case the user was basing the query on
503 ;; something in the message window).
504
505 (defun notmuch-tree-to-search ()
506   "Run \"notmuch search\" with the given `query' and display results."
507   (interactive)
508   (let ((query (notmuch-read-query "Notmuch search: ")))
509     (notmuch-tree-close-message-window)
510     (notmuch-search query)))
511
512 (defun notmuch-tree-to-tree ()
513   "Run a query and display results in tree view."
514   (interactive)
515   (let ((query (notmuch-read-query "Notmuch tree view search: ")))
516     (notmuch-tree-close-message-window)
517     (notmuch-tree query)))
518
519 (defun notmuch-tree-archive-thread-then-next ()
520   "Archive all messages in the current buffer, then show next thread from search."
521   (interactive)
522   (notmuch-tree-archive-thread)
523   (notmuch-tree-next-thread))
524
525 (defun notmuch-unthreaded-from-tree-current-query ()
526   "Switch from tree view to unthreaded view."
527   (interactive)
528   (unless notmuch-tree-unthreaded
529     (notmuch-tree-refresh-view 'unthreaded)))
530
531 (defun notmuch-tree-from-unthreaded-current-query ()
532   "Switch from unthreaded view to tree view."
533   (interactive)
534   (when notmuch-tree-unthreaded
535     (notmuch-tree-refresh-view 'tree)))
536
537 (defun notmuch-search-from-tree-current-query ()
538   "Call notmuch search with the current query."
539   (interactive)
540   (notmuch-tree-close-message-window)
541   (notmuch-search (notmuch-tree-get-query)))
542
543 (defun notmuch-tree-message-window-kill-hook ()
544   "Close the message pane when exiting the show buffer."
545   (let ((buffer (current-buffer)))
546     (when (and (window-live-p notmuch-tree-message-window)
547                (eq (window-buffer notmuch-tree-message-window) buffer))
548       ;; We could check whether this is the only window in its frame,
549       ;; but simply ignoring the error that is thrown otherwise is
550       ;; what we had to do for Emacs 24 and we stick to that because
551       ;; it is still the simplest approach.
552       (ignore-errors
553         (delete-window notmuch-tree-message-window)))))
554
555 (defun notmuch-tree-command-hook ()
556   (when (eq major-mode 'notmuch-tree-mode)
557     ;; We just run the notmuch-show-command-hook on the message pane.
558     (when (buffer-live-p notmuch-tree-message-buffer)
559       (with-current-buffer notmuch-tree-message-buffer
560         (notmuch-show-command-hook)))))
561
562 (defun notmuch-tree-show-message-in ()
563   "Show the current message (in split-pane)."
564   (interactive)
565   (let ((id (notmuch-tree-get-message-id))
566         (inhibit-read-only t)
567         buffer)
568     (when id
569       ;; We close and reopen the window to kill off un-needed buffers
570       ;; this might cause flickering but seems ok.
571       (notmuch-tree-close-message-window)
572       (setq notmuch-tree-message-window
573             (split-window-vertically (/ (window-height) 4)))
574       (with-selected-window notmuch-tree-message-window
575         (let (;; Since we are only displaying one message do not indent.
576               (notmuch-show-indent-messages-width 0)
577               (notmuch-show-only-matching-messages t)
578               ;; Ensure that `pop-to-buffer-same-window' uses the
579               ;; window we want it to use.
580               (display-buffer-overriding-action
581                  '((display-buffer-same-window)
582                    (inhibit-same-window . nil))))
583           (setq buffer (notmuch-show id))))
584       ;; We need the `let' as notmuch-tree-message-window is buffer local.
585       (let ((window notmuch-tree-message-window))
586         (with-current-buffer buffer
587           (setq notmuch-tree-message-window window)
588           (add-hook 'kill-buffer-hook 'notmuch-tree-message-window-kill-hook)))
589       (when notmuch-show-mark-read-tags
590         (notmuch-tree-tag-update-display notmuch-show-mark-read-tags))
591       (setq notmuch-tree-message-buffer buffer))))
592
593 (defun notmuch-tree-show-message-out ()
594   "Show the current message (in whole window)."
595   (interactive)
596   (let ((id (notmuch-tree-get-message-id))
597         (inhibit-read-only t))
598     (when id
599       ;; We close the window to kill off un-needed buffers.
600       (notmuch-tree-close-message-window)
601       (notmuch-show id))))
602
603 (defun notmuch-tree-show-message (arg)
604   "Show the current message.
605
606 Shows in split pane or whole window according to value of
607 `notmuch-tree-show-out'. A prefix argument reverses the choice."
608   (interactive "P")
609   (if (or (and (notmuch-tree-show-out) (not arg))
610           (and (not (notmuch-tree-show-out)) arg))
611       (notmuch-tree-show-message-out)
612     (notmuch-tree-show-message-in)))
613
614 (defun notmuch-tree-scroll-message-window ()
615   "Scroll the message window (if it exists)."
616   (interactive)
617   (when (window-live-p notmuch-tree-message-window)
618     (with-selected-window notmuch-tree-message-window
619       (if (pos-visible-in-window-p (point-max))
620           t
621         (scroll-up)))))
622
623 (defun notmuch-tree-scroll-message-window-back ()
624   "Scroll the message window back (if it exists)."
625   (interactive)
626   (when (window-live-p notmuch-tree-message-window)
627     (with-selected-window notmuch-tree-message-window
628       (if (pos-visible-in-window-p (point-min))
629           t
630         (scroll-down)))))
631
632 (defun notmuch-tree-scroll-or-next ()
633   "Scroll the message window.
634 If it at end go to next message."
635   (interactive)
636   (when (notmuch-tree-scroll-message-window)
637     (notmuch-tree-next-matching-message)))
638
639 (defun notmuch-tree-quit (&optional kill-both)
640   "Close the split view or exit tree."
641   (interactive "P")
642   (when (or (not (notmuch-tree-close-message-window)) kill-both)
643     (kill-buffer (current-buffer))))
644
645 (defun notmuch-tree-close-message-window ()
646   "Close the message-window. Return t if close succeeds."
647   (interactive)
648   (when (and (window-live-p notmuch-tree-message-window)
649              (eq (window-buffer notmuch-tree-message-window)
650                  notmuch-tree-message-buffer))
651     (delete-window notmuch-tree-message-window)
652     (unless (get-buffer-window-list notmuch-tree-message-buffer)
653       (kill-buffer notmuch-tree-message-buffer))
654     t))
655
656 (defun notmuch-tree-archive-message (&optional unarchive)
657   "Archive the current message.
658
659 Archive the current message by applying the tag changes in
660 `notmuch-archive-tags' to it. If a prefix argument is given, the
661 message will be \"unarchived\", i.e. the tag changes in
662 `notmuch-archive-tags' will be reversed."
663   (interactive "P")
664   (when notmuch-archive-tags
665     (notmuch-tree-tag
666      (notmuch-tag-change-list notmuch-archive-tags unarchive))))
667
668 (defun notmuch-tree-archive-message-then-next (&optional unarchive)
669   "Archive the current message and move to next matching message."
670   (interactive "P")
671   (notmuch-tree-archive-message unarchive)
672   (notmuch-tree-next-matching-message))
673
674 (defun notmuch-tree-archive-thread-then-exit ()
675   "Archive all messages in the current buffer, then exit notmuch-tree."
676   (interactive)
677   (notmuch-tree-archive-thread)
678   (notmuch-tree-quit t))
679
680 (defun notmuch-tree-archive-message-then-next-or-exit ()
681   "Archive current message, then show next open message in current thread.
682
683 If at the last open message in the current thread, then exit back
684 to search results."
685   (interactive)
686   (notmuch-tree-archive-message)
687   (notmuch-tree-next-matching-message t))
688
689 (defun notmuch-tree-next-message ()
690   "Move to next message."
691   (interactive)
692   (forward-line)
693   (when (window-live-p notmuch-tree-message-window)
694     (notmuch-tree-show-message-in)))
695
696 (defun notmuch-tree-prev-message ()
697   "Move to previous message."
698   (interactive)
699   (forward-line -1)
700   (when (window-live-p notmuch-tree-message-window)
701     (notmuch-tree-show-message-in)))
702
703 (defun notmuch-tree-goto-matching-message (&optional prev)
704   "Move to the next or previous matching message.
705
706 Returns t if there was a next matching message in the thread to show,
707 nil otherwise."
708   (let ((dir (if prev -1 nil))
709         (eobfn (if prev #'bobp #'eobp)))
710     (while (and (not (funcall eobfn))
711                 (not (notmuch-tree-get-match)))
712       (forward-line dir))
713     (not (funcall eobfn))))
714
715 (defun notmuch-tree-matching-message (&optional prev pop-at-end)
716   "Move to the next or previous matching message."
717   (interactive "P")
718   (forward-line (if prev -1 nil))
719   (if (and (not (notmuch-tree-goto-matching-message prev)) pop-at-end)
720       (notmuch-tree-quit pop-at-end)
721     (when (window-live-p notmuch-tree-message-window)
722       (notmuch-tree-show-message-in))))
723
724 (defun notmuch-tree-prev-matching-message (&optional pop-at-end)
725   "Move to previous matching message."
726   (interactive "P")
727   (notmuch-tree-matching-message t pop-at-end))
728
729 (defun notmuch-tree-next-matching-message (&optional pop-at-end)
730   "Move to next matching message."
731   (interactive "P")
732   (notmuch-tree-matching-message nil pop-at-end))
733
734 (defun notmuch-tree-refresh-view (&optional view)
735   "Refresh view."
736   (interactive)
737   (when (get-buffer-process (current-buffer))
738     (error "notmuch tree process already running for current buffer"))
739   (let ((inhibit-read-only t)
740         (basic-query notmuch-tree-basic-query)
741         (unthreaded (cond ((eq view 'unthreaded) t)
742                           ((eq view 'tree) nil)
743                           (t notmuch-tree-unthreaded)))
744         (query-context notmuch-tree-query-context)
745         (target (notmuch-tree-get-message-id)))
746     (erase-buffer)
747     (notmuch-tree-worker basic-query
748                          query-context
749                          target
750                          nil
751                          unthreaded)))
752
753 (defun notmuch-tree-thread-top ()
754   (when (notmuch-tree-get-message-properties)
755     (while (not (or (notmuch-tree-get-prop :first) (eobp)))
756       (forward-line -1))))
757
758 (defun notmuch-tree-prev-thread-in-tree ()
759   "Move to the previous thread in the current tree"
760   (interactive)
761   (forward-line -1)
762   (notmuch-tree-thread-top)
763   (not (bobp)))
764
765 (defun notmuch-tree-next-thread-in-tree ()
766   "Get the next thread in the current tree. Returns t if a thread was
767 found or nil if not."
768   (interactive)
769   (forward-line 1)
770   (while (not (or (notmuch-tree-get-prop :first) (eobp)))
771     (forward-line 1))
772   (not (eobp)))
773
774 (defun notmuch-tree-next-thread-from-search (&optional previous)
775   "Move to the next thread in the parent search results, if any.
776
777 If PREVIOUS is non-nil, move to the previous item in the
778 search results instead."
779   (interactive "P")
780   (let ((parent-buffer notmuch-tree-parent-buffer))
781     (notmuch-tree-quit t)
782     (when (buffer-live-p parent-buffer)
783       (switch-to-buffer parent-buffer)
784       (if previous
785           (notmuch-search-previous-thread)
786         (notmuch-search-next-thread))
787       (notmuch-tree-from-search-thread))))
788
789 (defun notmuch-tree-next-thread (&optional previous)
790   "Move to the next thread in the current tree or parent search results.
791
792 If PREVIOUS is non-nil, move to the previous thread in the tree or
793 search results instead."
794   (interactive)
795   (unless (if previous (notmuch-tree-prev-thread-in-tree)
796             (notmuch-tree-next-thread-in-tree))
797     (notmuch-tree-next-thread-from-search previous)))
798
799 (defun notmuch-tree-prev-thread ()
800   "Move to the previous thread in the current tree or parent search results."
801   (interactive)
802   (notmuch-tree-next-thread t))
803
804 (defun notmuch-tree-thread-mapcar (function)
805   "Call FUNCTION for each message in the current thread.
806 FUNCTION is called for side effects only."
807   (save-excursion
808     (notmuch-tree-thread-top)
809     (cl-loop collect (funcall function)
810              do (forward-line)
811              while (and (notmuch-tree-get-message-properties)
812                         (not (notmuch-tree-get-prop :first))))))
813
814 (defun notmuch-tree-get-messages-ids-thread-search ()
815   "Return a search string for all message ids of messages in the current thread."
816   (mapconcat 'identity
817              (notmuch-tree-thread-mapcar 'notmuch-tree-get-message-id)
818              " or "))
819
820 (defun notmuch-tree-tag-thread (tag-changes)
821   "Tag all messages in the current thread."
822   (interactive
823    (let ((tags (apply #'append (notmuch-tree-thread-mapcar
824                                 (lambda () (notmuch-tree-get-tags))))))
825      (list (notmuch-read-tag-changes tags "Tag thread"))))
826   (when (notmuch-tree-get-message-properties)
827     (notmuch-tag (notmuch-tree-get-messages-ids-thread-search) tag-changes)
828     (notmuch-tree-thread-mapcar
829      (lambda () (notmuch-tree-tag-update-display tag-changes)))))
830
831 (defun notmuch-tree-archive-thread (&optional unarchive)
832   "Archive each message in thread.
833
834 Archive each message currently shown by applying the tag changes
835 in `notmuch-archive-tags' to each. If a prefix argument is given,
836 the messages will be \"unarchived\", i.e. the tag changes in
837 `notmuch-archive-tags' will be reversed.
838
839 Note: This command is safe from any race condition of new messages
840 being delivered to the same thread. It does not archive the
841 entire thread, but only the messages shown in the current
842 buffer."
843   (interactive "P")
844   (when notmuch-archive-tags
845     (notmuch-tree-tag-thread
846      (notmuch-tag-change-list notmuch-archive-tags unarchive))))
847
848 ;;; Functions for displaying the tree buffer itself
849
850 (defun notmuch-tree-clean-address (address)
851   "Try to clean a single email ADDRESS for display. Return
852 AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return
853 unchanged ADDRESS if parsing fails."
854   (let* ((clean-address (notmuch-clean-address address))
855          (p-address (car clean-address))
856          (p-name (cdr clean-address)))
857
858     ;; If we have a name return that otherwise return the address.
859     (or p-name p-address)))
860
861 (defun notmuch-tree-format-field (field format-string msg)
862   "Format a FIELD of MSG according to FORMAT-STRING and return string."
863   (let* ((headers (plist-get msg :headers))
864          (match (plist-get msg :match)))
865     (cond
866      ((listp field)
867       (format format-string (notmuch-tree-format-field-list field msg)))
868
869      ((string-equal field "date")
870       (let ((face (if match
871                       'notmuch-tree-match-date-face
872                     'notmuch-tree-no-match-date-face)))
873         (propertize (format format-string (plist-get msg :date_relative))
874                     'face face)))
875
876      ((string-equal field "tree")
877       (let ((tree-status (plist-get msg :tree-status))
878             (face (if match
879                       'notmuch-tree-match-tree-face
880                     'notmuch-tree-no-match-tree-face)))
881
882         (propertize (format format-string
883                             (mapconcat #'identity (reverse tree-status) ""))
884                     'face face)))
885
886      ((string-equal field "subject")
887       (let ((bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))
888             (previous-subject notmuch-tree-previous-subject)
889             (face (if match
890                       'notmuch-tree-match-subject-face
891                     'notmuch-tree-no-match-subject-face)))
892
893         (setq notmuch-tree-previous-subject bare-subject)
894         (propertize (format format-string
895                             (if (string= previous-subject bare-subject)
896                                 " ..."
897                               bare-subject))
898                     'face face)))
899
900      ((string-equal field "authors")
901       (let ((author (notmuch-tree-clean-address (plist-get headers :From)))
902             (len (length (format format-string "")))
903             (face (if match
904                       'notmuch-tree-match-author-face
905                     'notmuch-tree-no-match-author-face)))
906         (when (> (length author) len)
907           (setq author (substring author 0 len)))
908         (propertize (format format-string author) 'face face)))
909
910      ((string-equal field "tags")
911       (let ((tags (plist-get msg :tags))
912             (orig-tags (plist-get msg :orig-tags))
913             (face (if match
914                       'notmuch-tree-match-tag-face
915                     'notmuch-tree-no-match-tag-face)))
916         (format format-string (notmuch-tag-format-tags tags orig-tags face)))))))
917
918 (defun notmuch-tree-format-field-list (field-list msg)
919   "Format fields of MSG according to FIELD-LIST and return string."
920   (let ((face (if (plist-get msg :match)
921                   'notmuch-tree-match-face
922                 'notmuch-tree-no-match-face))
923         (result-string))
924     (dolist (spec field-list result-string)
925       (let ((field-string (notmuch-tree-format-field (car spec) (cdr spec) msg)))
926         (setq result-string (concat result-string field-string))))
927     (notmuch-apply-face result-string face t)))
928
929 (defun notmuch-tree-insert-msg (msg)
930   "Insert the message MSG according to notmuch-tree-result-format."
931   ;; We need to save the previous subject as it will get overwritten
932   ;; by the insert-field calls.
933   (let ((previous-subject notmuch-tree-previous-subject))
934     (insert (notmuch-tree-format-field-list (notmuch-tree-result-format) msg))
935     (notmuch-tree-set-message-properties msg)
936     (notmuch-tree-set-prop :previous-subject previous-subject)
937     (insert "\n")))
938
939 (defun notmuch-tree-goto-and-insert-msg (msg)
940   "Insert msg at the end of the buffer. Move point to msg if it is the target."
941   (save-excursion
942     (goto-char (point-max))
943     (notmuch-tree-insert-msg msg))
944   (let ((msg-id (notmuch-id-to-query (plist-get msg :id)))
945         (target notmuch-tree-target-msg))
946     (when (or (and (not target) (plist-get msg :match))
947               (string= msg-id target))
948       (setq notmuch-tree-target-msg "found")
949       (goto-char (point-max))
950       (forward-line -1)
951       (when notmuch-tree-open-target
952         (notmuch-tree-show-message-in)))))
953
954 (defun notmuch-tree-insert-tree (tree depth tree-status first last)
955   "Insert the message tree TREE at depth DEPTH in the current thread.
956
957 A message tree is another name for a single sub-thread: i.e., a
958 message together with all its descendents."
959   (let ((msg (car tree))
960         (replies (cadr tree)))
961     (cond
962      ((and (< 0 depth) (not last))
963       (push "├" tree-status))
964      ((and (< 0 depth) last)
965       (push "╰" tree-status))
966      ((and (eq 0 depth) first last)
967       ;; Choice between these two variants is a matter of taste.
968       ;; (push "─" tree-status))
969       (push " " tree-status))
970      ((and (eq 0 depth) first (not last))
971       (push "┬" tree-status))
972      ((and (eq 0 depth) (not first) last)
973       (push "╰" tree-status))
974      ((and (eq 0 depth) (not first) (not last))
975       (push "├" tree-status)))
976     (push (concat (if replies "┬" "─") "►") tree-status)
977     (setq msg (plist-put msg :first (and first (eq 0 depth))))
978     (setq msg (plist-put msg :tree-status tree-status))
979     (setq msg (plist-put msg :orig-tags (plist-get msg :tags)))
980     (notmuch-tree-goto-and-insert-msg msg)
981     (pop tree-status)
982     (pop tree-status)
983     (if last
984         (push " " tree-status)
985       (push "│" tree-status))
986     (notmuch-tree-insert-thread replies (1+ depth) tree-status)))
987
988 (defun notmuch-tree-insert-thread (thread depth tree-status)
989   "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest."
990   (let ((n (length thread)))
991     (cl-loop for tree in thread
992              for count from 1 to n
993              do (notmuch-tree-insert-tree tree depth tree-status
994                                           (eq count 1)
995                                           (eq count n)))))
996
997 (defun notmuch-tree-insert-forest-thread (forest-thread)
998   "Insert a single complete thread."
999   (let (tree-status)
1000     ;; Reset at the start of each main thread.
1001     (setq notmuch-tree-previous-subject nil)
1002     (notmuch-tree-insert-thread forest-thread 0 tree-status)))
1003
1004 (defun notmuch-tree-insert-forest (forest)
1005   "Insert a forest of threads.
1006
1007 This function inserts a collection of several complete threads as
1008 passed to it by notmuch-tree-process-filter."
1009   (mapc 'notmuch-tree-insert-forest-thread forest))
1010
1011 (define-derived-mode notmuch-tree-mode fundamental-mode "notmuch-tree"
1012   "Major mode displaying messages (as opposed to threads) of a notmuch search.
1013
1014 This buffer contains the results of a \"notmuch tree\" of your
1015 email archives. Each line in the buffer represents a single
1016 message giving the relative date, the author, subject, and any
1017 tags.
1018
1019 Pressing \\[notmuch-tree-show-message] on any line displays that message.
1020
1021 Complete list of currently available key bindings:
1022
1023 \\{notmuch-tree-mode-map}"
1024   (setq notmuch-buffer-refresh-function #'notmuch-tree-refresh-view)
1025   (hl-line-mode 1)
1026   (setq buffer-read-only t)
1027   (setq truncate-lines t))
1028
1029 (defun notmuch-tree-process-sentinel (proc _msg)
1030   "Add a message to let user know when \"notmuch tree\" exits."
1031   (let ((buffer (process-buffer proc))
1032         (status (process-status proc))
1033         (exit-status (process-exit-status proc)))
1034     (when (memq status '(exit signal))
1035       (kill-buffer (process-get proc 'parse-buf))
1036       (when (buffer-live-p buffer)
1037         (with-current-buffer buffer
1038           (save-excursion
1039             (let ((inhibit-read-only t))
1040               (goto-char (point-max))
1041               (when (eq status 'signal)
1042                 (insert "Incomplete search results (tree view process was killed).\n"))
1043               (when (eq status 'exit)
1044                 (insert "End of search results.")
1045                 (unless (= exit-status 0)
1046                   (insert (format " (process returned %d)" exit-status)))
1047                 (insert "\n")))))))))
1048
1049 (defun notmuch-tree-process-filter (proc string)
1050   "Process and filter the output of \"notmuch show\" for tree view."
1051   (let ((results-buf (process-buffer proc))
1052         (parse-buf (process-get proc 'parse-buf))
1053         (inhibit-read-only t))
1054     (if (not (buffer-live-p results-buf))
1055         (delete-process proc)
1056       (with-current-buffer parse-buf
1057         ;; Insert new data
1058         (save-excursion
1059           (goto-char (point-max))
1060           (insert string))
1061         (notmuch-sexp-parse-partial-list 'notmuch-tree-insert-forest-thread
1062                                          results-buf)))))
1063
1064 (defun notmuch-tree-worker (basic-query &optional query-context target open-target unthreaded)
1065   "Insert the tree view of the search in the current buffer.
1066
1067 This is is a helper function for notmuch-tree. The arguments are
1068 the same as for the function notmuch-tree."
1069   (interactive)
1070   (notmuch-tree-mode)
1071   (add-hook 'post-command-hook #'notmuch-tree-command-hook t t)
1072   (setq notmuch-tree-unthreaded unthreaded)
1073   (setq notmuch-tree-basic-query basic-query)
1074   (setq notmuch-tree-query-context (if (or (string= query-context "")
1075                                            (string= query-context "*"))
1076                                        nil
1077                                      query-context))
1078   (setq notmuch-tree-target-msg target)
1079   (setq notmuch-tree-open-target open-target)
1080   ;; Set the default value for `notmuch-show-process-crypto' in this
1081   ;; buffer. Although we don't use this some of the functions we call
1082   ;; (such as reply) do. It is a buffer local variable so setting it
1083   ;; will not affect genuine show buffers.
1084   (setq notmuch-show-process-crypto notmuch-crypto-process-mime)
1085   (erase-buffer)
1086   (goto-char (point-min))
1087   (let* ((search-args (concat basic-query
1088                               (and query-context
1089                                    (concat " and (" query-context ")"))))
1090          (message-arg (if unthreaded "--unthreaded" "--entire-thread")))
1091     (when (equal (car (process-lines notmuch-command "count" search-args)) "0")
1092       (setq search-args basic-query))
1093     (notmuch-tag-clear-cache)
1094     (let ((proc (notmuch-start-notmuch
1095                  "notmuch-tree" (current-buffer) #'notmuch-tree-process-sentinel
1096                  "show" "--body=false" "--format=sexp" "--format-version=4"
1097                  message-arg search-args))
1098           ;; Use a scratch buffer to accumulate partial output.
1099           ;; This buffer will be killed by the sentinel, which
1100           ;; should be called no matter how the process dies.
1101           (parse-buf (generate-new-buffer " *notmuch tree parse*")))
1102       (process-put proc 'parse-buf parse-buf)
1103       (set-process-filter proc 'notmuch-tree-process-filter)
1104       (set-process-query-on-exit-flag proc nil))))
1105
1106 (defun notmuch-tree-get-query ()
1107   "Return the current query in this tree buffer."
1108   (if notmuch-tree-query-context
1109       (concat notmuch-tree-basic-query
1110               " and ("
1111               notmuch-tree-query-context
1112               ")")
1113     notmuch-tree-basic-query))
1114
1115 (defun notmuch-tree (&optional query query-context target buffer-name open-target unthreaded parent-buffer)
1116   "Display threads matching QUERY in tree view.
1117
1118 The arguments are:
1119   QUERY: the main query. This can be any query but in many cases will be
1120       a single thread. If nil this is read interactively from the minibuffer.
1121   QUERY-CONTEXT: is an additional term for the query. The query used
1122       is QUERY and QUERY-CONTEXT unless that does not match any messages
1123       in which case we fall back to just QUERY.
1124   TARGET: A message ID (with the id: prefix) that will be made
1125       current if it appears in the tree view results.
1126   BUFFER-NAME: the name of the buffer to display the tree view. If
1127       it is nil \"*notmuch-tree\" followed by QUERY is used.
1128   OPEN-TARGET: If TRUE open the target message in the message pane.
1129   UNTHREADED: If TRUE only show matching messages in an unthreaded view."
1130   (interactive)
1131   (unless query
1132     (setq query (notmuch-read-query (concat "Notmuch "
1133                                             (if unthreaded "unthreaded " "tree ")
1134                                             "view search: "))))
1135   (let ((buffer (get-buffer-create (generate-new-buffer-name
1136                                     (or buffer-name
1137                                         (concat "*notmuch-"
1138                                                 (if unthreaded "unthreaded-" "tree-")
1139                                                 query "*")))))
1140         (inhibit-read-only t))
1141     (pop-to-buffer-same-window buffer))
1142   ;; Don't track undo information for this buffer
1143   (setq buffer-undo-list t)
1144   (notmuch-tree-worker query query-context target open-target unthreaded)
1145   (setq notmuch-tree-parent-buffer parent-buffer)
1146   (setq truncate-lines t))
1147
1148 (defun notmuch-unthreaded (&optional query query-context target buffer-name open-target)
1149   (interactive)
1150   (notmuch-tree query query-context target buffer-name open-target t))
1151
1152 ;;; _
1153
1154 (provide 'notmuch-tree)
1155
1156 ;;; notmuch-tree.el ends here