contrib: pick: bind M-p and M-n to prev/next thread
[notmuch] / contrib / notmuch-pick / notmuch-pick.el
1 ;; notmuch-pick.el --- displaying notmuch forests.
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 <http://www.gnu.org/licenses/>.
21 ;;
22 ;; Authors: David Edmondson <dme@dme.org>
23 ;;          Mark Walters <markwalters1009@gmail.com>
24
25 (require 'mail-parse)
26
27 (require 'notmuch-lib)
28 (require 'notmuch-query)
29 (require 'notmuch-show)
30 (require 'notmuch) ;; XXX ATM, as notmuch-search-mode-map is defined here
31
32 (eval-when-compile (require 'cl))
33
34 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
35 (declare-function notmuch-show "notmuch-show" (&rest args))
36 (declare-function notmuch-tag "notmuch" (query &rest tags))
37 (declare-function notmuch-show-strip-re "notmuch-show" (subject))
38 (declare-function notmuch-show-spaces-n "notmuch-show" (n))
39 (declare-function notmuch-read-query "notmuch" (prompt))
40 (declare-function notmuch-read-tag-changes "notmuch" (&optional initial-input &rest search-terms))
41 (declare-function notmuch-update-tags "notmuch" (current-tags tag-changes))
42 (declare-function notmuch-hello-trim "notmuch-hello" (search))
43 (declare-function notmuch-search-find-thread-id "notmuch" ())
44 (declare-function notmuch-search-find-subject "notmuch" ())
45
46 ;; the following variable is defined in notmuch.el
47 (defvar notmuch-search-query-string)
48
49 (defgroup notmuch-pick nil
50   "Showing message and thread structure."
51   :group 'notmuch)
52
53 ;; This is ugly. We can't run setup-show-out until it has been defined
54 ;; which needs the keymap to be defined. So we defer setting up to
55 ;; notmuch-pick-init.
56 (defcustom notmuch-pick-show-out nil
57   "View selected messages in new window rather than split-pane."
58   :type 'boolean
59   :group 'notmuch-pick
60   :set (lambda (symbol value)
61          (set-default symbol value)
62          (when (fboundp 'notmuch-pick-setup-show-out)
63            (notmuch-pick-setup-show-out))))
64
65 (defcustom notmuch-pick-result-format
66   `(("date" . "%12s  ")
67     ("authors" . "%-20s")
68     ("subject" . " %-54s ")
69     ("tags" . "(%s)"))
70   "Result formatting for Pick. Supported fields are: date,
71         authors, subject, tags Note: subject includes the tree
72         structure graphics, and the author string should not
73         contain whitespace (put it in the neighbouring fields
74         instead).  For example:
75         (setq notmuch-pick-result-format \(\(\"authors\" . \"%-40s\"\)
76                                              \(\"subject\" . \"%s\"\)\)\)"
77   :type '(alist :key-type (string) :value-type (string))
78   :group 'notmuch-pick)
79
80 ;; Faces for messages that match the query.
81 (defface notmuch-pick-match-date-face
82   '((t :inherit default))
83   "Face used in pick mode for the date in messages matching the query."
84   :group 'notmuch-pick
85   :group 'notmuch-faces)
86
87 (defface notmuch-pick-match-author-face
88   '((((class color)
89       (background dark))
90      (:foreground "OliveDrab1"))
91     (((class color)
92       (background light))
93      (:foreground "dark blue"))
94     (t
95      (:bold t)))
96   "Face used in pick mode for the date in messages matching the query."
97   :group 'notmuch-pick
98   :group 'notmuch-faces)
99
100 (defface notmuch-pick-match-subject-face
101   '((t :inherit default))
102   "Face used in pick mode for the subject in messages matching the query."
103   :group 'notmuch-pick
104   :group 'notmuch-faces)
105
106 (defface notmuch-pick-match-tag-face
107   '((((class color)
108       (background dark))
109      (:foreground "OliveDrab1"))
110     (((class color)
111       (background light))
112      (:foreground "navy blue" :bold t))
113     (t
114      (:bold t)))
115   "Face used in pick mode for tags in messages matching the query."
116   :group 'notmuch-pick
117   :group 'notmuch-faces)
118
119 ;; Faces for messages that do not match the query.
120 (defface notmuch-pick-no-match-date-face
121   '((t (:foreground "gray")))
122   "Face used in pick mode for non-matching dates."
123   :group 'notmuch-pick
124   :group 'notmuch-faces)
125
126 (defface notmuch-pick-no-match-subject-face
127   '((t (:foreground "gray")))
128   "Face used in pick mode for non-matching subjects."
129   :group 'notmuch-pick
130   :group 'notmuch-faces)
131
132 (defface notmuch-pick-no-match-author-face
133   '((t (:foreground "gray")))
134   "Face used in pick mode for the date in messages matching the query."
135   :group 'notmuch-pick
136   :group 'notmuch-faces)
137
138 (defface notmuch-pick-no-match-tag-face
139   '((t (:foreground "gray")))
140   "Face used in pick mode face for non-matching tags."
141   :group 'notmuch-pick
142   :group 'notmuch-faces)
143
144 (defvar notmuch-pick-previous-subject
145   "The subject of the most recent result shown during the async display")
146 (make-variable-buffer-local 'notmuch-pick-previous-subject)
147
148 (defvar notmuch-pick-basic-query nil
149   "A buffer local copy of argument query to the function notmuch-pick")
150 (make-variable-buffer-local 'notmuch-pick-basic-query)
151
152 (defvar notmuch-pick-query-context nil
153   "A buffer local copy of argument query-context to the function notmuch-pick")
154 (make-variable-buffer-local 'notmuch-pick-query-context)
155
156 (defvar notmuch-pick-target-msg nil
157   "A buffer local copy of argument target to the function notmuch-pick")
158 (make-variable-buffer-local 'notmuch-pick-target-msg)
159
160 (defvar notmuch-pick-open-target nil
161   "A buffer local copy of argument open-target to the function notmuch-pick")
162 (make-variable-buffer-local 'notmuch-pick-open-target)
163
164 (defvar notmuch-pick-buffer-name nil
165   "A buffer local copy of argument buffer-name to the function notmuch-pick")
166 (make-variable-buffer-local 'notmuch-pick-buffer-name)
167
168 (defvar notmuch-pick-message-window nil
169   "The window of the message pane.
170
171 It is set in both the pick buffer and the child show buffer. It
172 is used to try and close the message pane when quitting pick or
173 the child show buffer.")
174 (make-variable-buffer-local 'notmuch-pick-message-window)
175 (put 'notmuch-pick-message-window 'permanent-local t)
176
177 (defvar notmuch-pick-message-buffer nil
178   "The buffer name of the show buffer in the message pane.
179
180 This is used to try and make sure we don't close the message pane
181 if the user has loaded a different buffer in that window.")
182 (make-variable-buffer-local 'notmuch-pick-message-buffer)
183 (put 'notmuch-pick-message-buffer 'permanent-local t)
184
185 (defun notmuch-pick-to-message-pane (func)
186   "Execute FUNC in message pane.
187
188 This function returns a function (so can be used as a keybinding)
189 which executes function FUNC in the message pane if it is
190 open (if the message pane is closed it does nothing)."
191   `(lambda ()
192       ,(concat "(In message pane) " (documentation func t))
193      (interactive)
194      (when (window-live-p notmuch-pick-message-window)
195        (with-selected-window notmuch-pick-message-window
196          (call-interactively #',func)))))
197
198 (defun notmuch-pick-button-activate (&optional button)
199   "Activate BUTTON or button at point
200
201 This function does not give an error if there is no button."
202   (interactive)
203   (let ((button (or button (button-at (point)))))
204     (when button (button-activate button))))
205
206 (defun notmuch-pick-close-message-pane-and (func)
207   "Close message pane and execute FUNC.
208
209 This function returns a function (so can be used as a keybinding)
210 which closes the message pane if open and then executes function
211 FUNC."
212   `(lambda ()
213       ,(concat "(Close message pane and) " (documentation func t))
214      (interactive)
215      (notmuch-pick-close-message-window)
216      (call-interactively #',func)))
217
218 (defvar notmuch-pick-mode-map
219   (let ((map (make-sparse-keymap)))
220     (define-key map [mouse-1] 'notmuch-pick-show-message)
221     ;; these use notmuch-show functions directly
222     (define-key map "|" 'notmuch-show-pipe-message)
223     (define-key map "w" 'notmuch-show-save-attachments)
224     (define-key map "v" 'notmuch-show-view-all-mime-parts)
225     (define-key map "c" 'notmuch-show-stash-map)
226
227     ;; these apply to the message pane
228     (define-key map (kbd "M-TAB") (notmuch-pick-to-message-pane #'notmuch-show-previous-button))
229     (define-key map (kbd "<backtab>")  (notmuch-pick-to-message-pane #'notmuch-show-previous-button))
230     (define-key map (kbd "TAB") (notmuch-pick-to-message-pane #'notmuch-show-next-button))
231     (define-key map "e" (notmuch-pick-to-message-pane #'notmuch-pick-button-activate))
232
233     ;; bindings from show (or elsewhere) but we close the message pane first.
234     (define-key map "m" (notmuch-pick-close-message-pane-and #'notmuch-mua-new-mail))
235     (define-key map "f" (notmuch-pick-close-message-pane-and #'notmuch-show-forward-message))
236     (define-key map "r" (notmuch-pick-close-message-pane-and #'notmuch-show-reply-sender))
237     (define-key map "R" (notmuch-pick-close-message-pane-and #'notmuch-show-reply))
238     (define-key map "V" (notmuch-pick-close-message-pane-and #'notmuch-show-view-raw-message))
239     (define-key map "?" (notmuch-pick-close-message-pane-and #'notmuch-help))
240
241     ;; The main pick bindings
242     (define-key map "q" 'notmuch-pick-quit)
243     (define-key map "x" 'notmuch-pick-quit)
244     (define-key map "A" 'notmuch-pick-archive-thread)
245     (define-key map "a" 'notmuch-pick-archive-message-then-next)
246     (define-key map "=" 'notmuch-pick-refresh-view)
247     (define-key map "s" 'notmuch-pick-to-search)
248     (define-key map "z" 'notmuch-pick-to-pick)
249     (define-key map "n" 'notmuch-pick-next-matching-message)
250     (define-key map "p" 'notmuch-pick-prev-matching-message)
251     (define-key map "N" 'notmuch-pick-next-message)
252     (define-key map "P" 'notmuch-pick-prev-message)
253     (define-key map (kbd "M-p") 'notmuch-pick-prev-thread)
254     (define-key map (kbd "M-n") 'notmuch-pick-next-thread)
255     (define-key map "-" 'notmuch-pick-remove-tag)
256     (define-key map "+" 'notmuch-pick-add-tag)
257     (define-key map "*" 'notmuch-pick-tag-thread)
258     (define-key map " " 'notmuch-pick-scroll-or-next)
259     (define-key map "b" 'notmuch-pick-scroll-message-window-back)
260     map))
261 (fset 'notmuch-pick-mode-map notmuch-pick-mode-map)
262
263 (defun notmuch-pick-setup-show-out ()
264   "Set up the keymap for showing a thread
265
266 This uses the value of the defcustom notmuch-pick-show-out to
267 decide whether to show a message in the message pane or in the
268 whole window."
269   (let ((map notmuch-pick-mode-map))
270     (if notmuch-pick-show-out
271         (progn
272           (define-key map (kbd "M-RET") 'notmuch-pick-show-message)
273           (define-key map (kbd "RET") 'notmuch-pick-show-message-out))
274       (progn
275         (define-key map (kbd "RET") 'notmuch-pick-show-message)
276         (define-key map (kbd "M-RET") 'notmuch-pick-show-message-out)))))
277
278 (defun notmuch-pick-get-message-properties ()
279   "Return the properties of the current message as a plist.
280
281 Some useful entries are:
282 :headers - Property list containing the headers :Date, :Subject, :From, etc.
283 :tags - Tags for this message"
284   (save-excursion
285     (beginning-of-line)
286     (get-text-property (point) :notmuch-message-properties)))
287
288 ;; XXX This should really be a lib function but we are trying to
289 ;; reduce impact on the code base.
290 (defun notmuch-show-get-prop (prop &optional props)
291   "This is a pick overridden version of notmuch-show-get-prop
292
293 It gets property PROP from PROPS or, if PROPS is nil, the current
294 message in either pick or show. This means that several functions
295 in notmuch-show now work unchanged in pick as they just need the
296 correct message properties."
297   (let ((props (or props
298                    (cond ((eq major-mode 'notmuch-show-mode)
299                           (notmuch-show-get-message-properties))
300                          ((eq major-mode 'notmuch-pick-mode)
301                           (notmuch-pick-get-message-properties))))))
302     (plist-get props prop)))
303
304 (defun notmuch-pick-set-message-properties (props)
305   (save-excursion
306     (beginning-of-line)
307     (put-text-property (point) (+ (point) 1) :notmuch-message-properties props)))
308
309 (defun notmuch-pick-set-prop (prop val &optional props)
310   (let ((inhibit-read-only t)
311         (props (or props
312                    (notmuch-pick-get-message-properties))))
313     (plist-put props prop val)
314     (notmuch-pick-set-message-properties props)))
315
316 (defun notmuch-pick-get-prop (prop &optional props)
317   (let ((props (or props
318                    (notmuch-pick-get-message-properties))))
319     (plist-get props prop)))
320
321 (defun notmuch-pick-set-tags (tags)
322   "Set the tags of the current message."
323   (notmuch-pick-set-prop :tags tags))
324
325 (defun notmuch-pick-get-tags ()
326   "Return the tags of the current message."
327   (notmuch-pick-get-prop :tags))
328
329 (defun notmuch-pick-get-message-id ()
330   "Return the message id of the current message."
331   (let ((id (notmuch-pick-get-prop :id)))
332     (if id
333         (notmuch-id-to-query id)
334       nil)))
335
336 (defun notmuch-pick-get-match ()
337   "Return whether the current message is a match."
338   (interactive)
339   (notmuch-pick-get-prop :match))
340
341 (defun notmuch-pick-refresh-result ()
342   "Redisplay the current message line.
343
344 This redisplays the current line based on the messages
345 properties (as they are now). This is used when tags are
346 updated."
347   (let ((init-point (point))
348         (end (line-end-position))
349         (msg (notmuch-pick-get-message-properties))
350         (inhibit-read-only t))
351     (beginning-of-line)
352     ;; This is a little tricky: we override
353     ;; notmuch-pick-previous-subject to get the decision between
354     ;; ... and a subject right and it stops notmuch-pick-insert-msg
355     ;; from overwriting the buffer local copy of
356     ;; notmuch-pick-previous-subject if this is called while the
357     ;; buffer is displaying.
358     (let ((notmuch-pick-previous-subject (notmuch-pick-get-prop :previous-subject)))
359       (delete-region (point) (1+ (line-end-position)))
360       (notmuch-pick-insert-msg msg))
361     (let ((new-end (line-end-position)))
362       (goto-char (if (= init-point end)
363                      new-end
364                    (min init-point (- new-end 1)))))))
365
366 (defun notmuch-pick-tag-update-display (&optional tag-changes)
367   "Update display for TAG-CHANGES to current message.
368
369 Does NOT change the database."
370   (let* ((current-tags (notmuch-pick-get-tags))
371          (new-tags (notmuch-update-tags current-tags tag-changes)))
372     (unless (equal current-tags new-tags)
373       (notmuch-pick-set-tags new-tags)
374       (notmuch-pick-refresh-result))))
375
376 (defun notmuch-pick-tag (&optional tag-changes)
377   "Change tags for the current message"
378   (interactive)
379   (setq tag-changes (notmuch-tag (notmuch-pick-get-message-id) tag-changes))
380   (notmuch-pick-tag-update-display tag-changes))
381
382 (defun notmuch-pick-add-tag ()
383   "Same as `notmuch-pick-tag' but sets initial input to '+'."
384   (interactive)
385   (notmuch-pick-tag "+"))
386
387 (defun notmuch-pick-remove-tag ()
388   "Same as `notmuch-pick-tag' but sets initial input to '-'."
389   (interactive)
390   (notmuch-pick-tag "-"))
391
392 ;; The next two functions close the message window before searching or
393 ;; picking but they do so after the user has entered the query (in
394 ;; case the user was basing the query on something in the message
395 ;; window).
396
397 (defun notmuch-pick-to-search ()
398   "Run \"notmuch search\" with the given `query' and display results."
399   (interactive)
400   (let ((query (notmuch-read-query "Notmuch search: ")))
401     (notmuch-pick-close-message-window)
402     (notmuch-search query)))
403
404 (defun notmuch-pick-to-pick ()
405   "Run a query and display results in experimental notmuch-pick mode"
406   (interactive)
407   (let ((query (notmuch-read-query "Notmuch pick: ")))
408     (notmuch-pick-close-message-window)
409     (notmuch-pick query)))
410
411 ;; This function should be in notmuch-hello.el but we are trying to
412 ;; minimise impact on the rest of the codebase.
413 (defun notmuch-pick-from-hello (&optional search)
414   "Run a query and display results in experimental notmuch-pick mode"
415   (interactive)
416   (unless (null search)
417     (setq search (notmuch-hello-trim search))
418     (let ((history-delete-duplicates t))
419       (add-to-history 'notmuch-search-history search)))
420   (notmuch-pick search))
421
422 ;; This function should be in notmuch-show.el but be we trying to
423 ;; minimise impact on the rest of the codebase.
424 (defun notmuch-pick-from-show-current-query ()
425   "Call notmuch pick with the current query"
426   (interactive)
427   (notmuch-pick notmuch-show-thread-id
428                 notmuch-show-query-context
429                 (notmuch-show-get-message-id)))
430
431 ;; This function should be in notmuch.el but be we trying to minimise
432 ;; impact on the rest of the codebase.
433 (defun notmuch-pick-from-search-current-query ()
434   "Call notmuch pick with the current query"
435   (interactive)
436   (notmuch-pick notmuch-search-query-string))
437
438 ;; This function should be in notmuch.el but be we trying to minimise
439 ;; impact on the rest of the codebase.
440 (defun notmuch-pick-from-search-thread ()
441   "Show the selected thread with notmuch-pick"
442   (interactive)
443   (notmuch-pick (notmuch-search-find-thread-id)
444                 notmuch-search-query-string
445                 nil
446                 (notmuch-prettify-subject (notmuch-search-find-subject))
447                 t))
448
449 (defun notmuch-pick-message-window-kill-hook ()
450   "Close the message pane when exiting the show buffer."
451   (let ((buffer (current-buffer)))
452     (when (and (window-live-p notmuch-pick-message-window)
453                (eq (window-buffer notmuch-pick-message-window) buffer))
454       ;; We do not want an error if this is the sole window in the
455       ;; frame and I do not know how to test for that in emacs pre
456       ;; 24. Hence we just ignore-errors.
457       (ignore-errors
458         (delete-window notmuch-pick-message-window)))))
459
460 (defun notmuch-pick-show-message ()
461   "Show the current message (in split-pane)."
462   (interactive)
463   (let ((id (notmuch-pick-get-message-id))
464         (inhibit-read-only t)
465         buffer)
466     (when id
467       ;; We close and reopen the window to kill off un-needed buffers
468       ;; this might cause flickering but seems ok.
469       (notmuch-pick-close-message-window)
470       (setq notmuch-pick-message-window
471             (split-window-vertically (/ (window-height) 4)))
472       (with-selected-window notmuch-pick-message-window
473         ;; Since we are only displaying one message do not indent.
474         (let ((notmuch-show-indent-messages-width 0)
475               (notmuch-show-only-matching-messages t))
476           (setq buffer (notmuch-show id nil nil nil))))
477       ;; We need the `let' as notmuch-pick-message-window is buffer local.
478       (let ((window notmuch-pick-message-window))
479         (with-current-buffer buffer
480           (setq notmuch-pick-message-window window)
481           (add-hook 'kill-buffer-hook 'notmuch-pick-message-window-kill-hook)))
482       (when notmuch-show-mark-read-tags
483         (notmuch-pick-tag-update-display notmuch-show-mark-read-tags))
484       (setq notmuch-pick-message-buffer buffer))))
485
486 (defun notmuch-pick-show-message-out ()
487   "Show the current message (in whole window)."
488   (interactive)
489   (let ((id (notmuch-pick-get-message-id))
490         (inhibit-read-only t)
491         buffer)
492     (when id
493       ;; We close the window to kill off un-needed buffers.
494       (notmuch-pick-close-message-window)
495       (notmuch-show id nil nil nil))))
496
497 (defun notmuch-pick-scroll-message-window ()
498   "Scroll the message window (if it exists)"
499   (interactive)
500   (when (window-live-p notmuch-pick-message-window)
501     (with-selected-window notmuch-pick-message-window
502       (if (pos-visible-in-window-p (point-max))
503           t
504         (scroll-up)))))
505
506 (defun notmuch-pick-scroll-message-window-back ()
507   "Scroll the message window back(if it exists)"
508   (interactive)
509   (when (window-live-p notmuch-pick-message-window)
510     (with-selected-window notmuch-pick-message-window
511       (if (pos-visible-in-window-p (point-min))
512           t
513         (scroll-down)))))
514
515 (defun notmuch-pick-scroll-or-next ()
516   "Scroll the message window. If it at end go to next message."
517   (interactive)
518   (when (notmuch-pick-scroll-message-window)
519     (notmuch-pick-next-matching-message)))
520
521 (defun notmuch-pick-quit ()
522   "Close the split view or exit pick."
523   (interactive)
524   (unless (notmuch-pick-close-message-window)
525     (kill-buffer (current-buffer))))
526
527 (defun notmuch-pick-close-message-window ()
528   "Close the message-window. Return t if close succeeds."
529   (interactive)
530   (when (and (window-live-p notmuch-pick-message-window)
531              (eq (window-buffer notmuch-pick-message-window) notmuch-pick-message-buffer))
532     (delete-window notmuch-pick-message-window)
533     (unless (get-buffer-window-list notmuch-pick-message-buffer)
534       (kill-buffer notmuch-pick-message-buffer))
535     t))
536
537 (defun notmuch-pick-archive-message (&optional unarchive)
538   "Archive the current message.
539
540 Archive the current message by applying the tag changes in
541 `notmuch-archive-tags' to it. If a prefix argument is given, the
542 message will be \"unarchived\", i.e. the tag changes in
543 `notmuch-archive-tags' will be reversed."
544   (interactive "P")
545   (when notmuch-archive-tags
546     (apply 'notmuch-pick-tag
547            (notmuch-tag-change-list notmuch-archive-tags unarchive))))
548
549 (defun notmuch-pick-archive-message-then-next (&optional unarchive)
550   "Archive the current message and move to next matching message."
551   (interactive "P")
552   (notmuch-pick-archive-message unarchive)
553   (notmuch-pick-next-matching-message))
554
555 (defun notmuch-pick-next-message ()
556   "Move to next message."
557   (interactive)
558   (forward-line)
559   (when (window-live-p notmuch-pick-message-window)
560     (notmuch-pick-show-message)))
561
562 (defun notmuch-pick-prev-message ()
563   "Move to previous message."
564   (interactive)
565   (forward-line -1)
566   (when (window-live-p notmuch-pick-message-window)
567     (notmuch-pick-show-message)))
568
569 (defun notmuch-pick-prev-matching-message ()
570   "Move to previous matching message."
571   (interactive)
572   (forward-line -1)
573   (while (and (not (bobp)) (not (notmuch-pick-get-match)))
574     (forward-line -1))
575   (when (window-live-p notmuch-pick-message-window)
576     (notmuch-pick-show-message)))
577
578 (defun notmuch-pick-next-matching-message ()
579   "Move to next matching message."
580   (interactive)
581   (forward-line)
582   (while (and (not (eobp)) (not (notmuch-pick-get-match)))
583     (forward-line))
584   (when (window-live-p notmuch-pick-message-window)
585     (notmuch-pick-show-message)))
586
587 (defun notmuch-pick-refresh-view ()
588   "Refresh view."
589   (interactive)
590   (let ((inhibit-read-only t)
591         (basic-query notmuch-pick-basic-query)
592         (query-context notmuch-pick-query-context)
593         (target (notmuch-pick-get-message-id))
594         (buffer-name notmuch-pick-buffer-name))
595     (erase-buffer)
596     (notmuch-pick-worker basic-query
597                          query-context
598                          target
599                          (get-buffer buffer-name))))
600
601 (defun notmuch-pick-thread-top ()
602   (when (notmuch-pick-get-message-properties)
603     (while (not (or (notmuch-pick-get-prop :first) (eobp)))
604       (forward-line -1))))
605
606 (defun notmuch-pick-prev-thread ()
607   (interactive)
608   (forward-line -1)
609   (notmuch-pick-thread-top))
610
611 (defun notmuch-pick-next-thread ()
612   (interactive)
613   (forward-line 1)
614   (while (not (or (notmuch-pick-get-prop :first) (eobp)))
615     (forward-line 1)))
616
617 (defun notmuch-pick-thread-mapcar (function)
618   "Iterate through all messages in the current thread
619  and call FUNCTION for side effects."
620   (save-excursion
621     (notmuch-pick-thread-top)
622     (loop collect (funcall function)
623           do (forward-line)
624           while (and (notmuch-pick-get-message-properties)
625                      (not (notmuch-pick-get-prop :first))))))
626
627 (defun notmuch-pick-get-messages-ids-thread-search ()
628   "Return a search string for all message ids of messages in the current thread."
629   (mapconcat 'identity
630              (notmuch-pick-thread-mapcar 'notmuch-pick-get-message-id)
631              " or "))
632
633 (defun notmuch-pick-tag-thread (&optional tag-changes)
634   "Tag all messages in the current thread"
635   (interactive)
636   (when (notmuch-pick-get-message-properties)
637     (let ((tag-changes (notmuch-tag (notmuch-pick-get-messages-ids-thread-search) tag-changes)))
638       (notmuch-pick-thread-mapcar
639        (lambda () (notmuch-pick-tag-update-display tag-changes))))))
640
641 (defun notmuch-pick-archive-thread (&optional unarchive)
642   "Archive each message in thread.
643
644 Archive each message currently shown by applying the tag changes
645 in `notmuch-archive-tags' to each. If a prefix argument is given,
646 the messages will be \"unarchived\", i.e. the tag changes in
647 `notmuch-archive-tags' will be reversed.
648
649 Note: This command is safe from any race condition of new messages
650 being delivered to the same thread. It does not archive the
651 entire thread, but only the messages shown in the current
652 buffer."
653   (interactive "P")
654   (when notmuch-archive-tags
655     (notmuch-pick-tag-thread
656      (notmuch-tag-change-list notmuch-archive-tags unarchive))))
657
658 ;; Functions below here display the pick buffer itself.
659
660 (defun notmuch-pick-clean-address (address)
661   "Try to clean a single email ADDRESS for display. Return
662 AUTHOR_NAME if present, otherwise return AUTHOR_EMAIL. Return
663 unchanged ADDRESS if parsing fails."
664   (let* ((clean-address (notmuch-clean-address address))
665          (p-address (car clean-address))
666          (p-name (cdr clean-address)))
667
668     ;; If we have a name return that otherwise return the address.
669     (or p-name p-address)))
670
671 (defun notmuch-pick-insert-field (field format-string msg)
672   (let* ((headers (plist-get msg :headers))
673         (match (plist-get msg :match)))
674     (cond
675      ((string-equal field "date")
676       (let ((face (if match
677                       'notmuch-pick-match-date-face
678                     'notmuch-pick-no-match-date-face)))
679         (insert (propertize (format format-string (plist-get msg :date_relative))
680                             'face face))))
681
682      ((string-equal field "subject")
683       (let ((tree-status (plist-get msg :tree-status))
684             (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))
685             (face (if match
686                       'notmuch-pick-match-subject-face
687                     'notmuch-pick-no-match-subject-face)))
688         (insert (propertize (format format-string
689                                     (concat
690                                      (mapconcat #'identity (reverse tree-status) "")
691                                      (if (string= notmuch-pick-previous-subject bare-subject)
692                                          " ..."
693                                        bare-subject)))
694                             'face face))
695         (setq notmuch-pick-previous-subject bare-subject)))
696
697      ((string-equal field "authors")
698       (let ((author (notmuch-pick-clean-address (plist-get headers :From)))
699             (len (length (format format-string "")))
700             (face (if match
701                       'notmuch-pick-match-author-face
702                     'notmuch-pick-no-match-author-face)))
703         (when (> (length author) len)
704           (setq author (substring author 0 len)))
705         (insert (propertize (format format-string author)
706                             'face face))))
707
708      ((string-equal field "tags")
709       (let ((tags (plist-get msg :tags))
710             (face (if match
711                           'notmuch-pick-match-tag-face
712                         'notmuch-pick-no-match-tag-face)))
713         (when tags
714           (insert (propertize (format format-string
715                                       (mapconcat #'identity tags ", "))
716                               'face face))))))))
717
718 (defun notmuch-pick-insert-msg (msg)
719   "Insert the message MSG according to notmuch-pick-result-format"
720   ;; We need to save the previous subject as it will get overwritten
721   ;; by the insert-field calls.
722   (let ((previous-subject notmuch-pick-previous-subject))
723     (dolist (spec notmuch-pick-result-format)
724       (notmuch-pick-insert-field (car spec) (cdr spec) msg))
725     (notmuch-pick-set-message-properties msg)
726     (notmuch-pick-set-prop :previous-subject previous-subject)
727     (insert "\n")))
728
729 (defun notmuch-pick-goto-and-insert-msg (msg)
730   "Insert msg at the end of the buffer. Move point to msg if it is the target"
731   (save-excursion
732     (goto-char (point-max))
733     (notmuch-pick-insert-msg msg))
734   (let ((msg-id (notmuch-id-to-query (plist-get msg :id)))
735         (target notmuch-pick-target-msg))
736     (when (or (and (not target) (plist-get msg :match))
737               (string= msg-id target))
738       (setq notmuch-pick-target-msg "found")
739       (goto-char (point-max))
740       (forward-line -1)
741       (when notmuch-pick-open-target
742         (notmuch-pick-show-message)))))
743
744 (defun notmuch-pick-insert-tree (tree depth tree-status first last)
745   "Insert the message tree TREE at depth DEPTH in the current thread.
746
747 A message tree is another name for a single sub-thread: i.e., a
748 message together with all its descendents."
749   (let ((msg (car tree))
750         (replies (cadr tree)))
751
752       (cond
753        ((and (< 0 depth) (not last))
754         (push "├" tree-status))
755        ((and (< 0 depth) last)
756         (push "╰" tree-status))
757        ((and (eq 0 depth) first last)
758 ;;        (push "─" tree-status)) choice between this and next line is matter of taste.
759         (push " " tree-status))
760        ((and (eq 0 depth) first (not last))
761           (push "┬" tree-status))
762        ((and (eq 0 depth) (not first) last)
763         (push "╰" tree-status))
764        ((and (eq 0 depth) (not first) (not last))
765         (push "├" tree-status)))
766
767       (push (concat (if replies "┬" "─") "►") tree-status)
768       (plist-put msg :first (and first (eq 0 depth)))
769       (notmuch-pick-goto-and-insert-msg (plist-put msg :tree-status tree-status))
770       (pop tree-status)
771       (pop tree-status)
772
773       (if last
774           (push " " tree-status)
775         (push "│" tree-status))
776
777     (notmuch-pick-insert-thread replies (1+ depth) tree-status)))
778
779 (defun notmuch-pick-insert-thread (thread depth tree-status)
780   "Insert the collection of sibling sub-threads THREAD at depth DEPTH in the current forest."
781   (let ((n (length thread)))
782     (loop for tree in thread
783           for count from 1 to n
784
785           do (notmuch-pick-insert-tree tree depth tree-status (eq count 1) (eq count n)))))
786
787 (defun notmuch-pick-insert-forest-thread (forest-thread)
788   "Insert a single complete thread."
789   (let (tree-status)
790     ;; Reset at the start of each main thread.
791     (setq notmuch-pick-previous-subject nil)
792     (notmuch-pick-insert-thread forest-thread 0 tree-status)))
793
794 (defun notmuch-pick-insert-forest (forest)
795   "Insert a forest of threads.
796
797 This function inserts a collection of several complete threads as
798 passed to it by notmuch-pick-process-filter."
799   (mapc 'notmuch-pick-insert-forest-thread forest))
800
801 (defun notmuch-pick-mode ()
802   "Major mode displaying messages (as opposed to threads) of of a notmuch search.
803
804 This buffer contains the results of a \"notmuch pick\" of your
805 email archives. Each line in the buffer represents a single
806 message giving the relative date, the author, subject, and any
807 tags.
808
809 Pressing \\[notmuch-pick-show-message] on any line displays that message.
810
811 Complete list of currently available key bindings:
812
813 \\{notmuch-pick-mode-map}"
814
815   (interactive)
816   (kill-all-local-variables)
817   (use-local-map notmuch-pick-mode-map)
818   (setq major-mode 'notmuch-pick-mode
819         mode-name "notmuch-pick")
820   (hl-line-mode 1)
821   (setq buffer-read-only t
822         truncate-lines t))
823
824 (defun notmuch-pick-process-sentinel (proc msg)
825   "Add a message to let user know when \"notmuch pick\" exits"
826   (let ((buffer (process-buffer proc))
827         (status (process-status proc))
828         (exit-status (process-exit-status proc))
829         (never-found-target-thread nil))
830     (when (memq status '(exit signal))
831         (kill-buffer (process-get proc 'parse-buf))
832         (if (buffer-live-p buffer)
833             (with-current-buffer buffer
834               (save-excursion
835                 (let ((inhibit-read-only t)
836                       (atbob (bobp)))
837                   (goto-char (point-max))
838                   (if (eq status 'signal)
839                       (insert "Incomplete search results (pick process was killed).\n"))
840                   (when (eq status 'exit)
841                     (insert "End of search results.")
842                     (unless (= exit-status 0)
843                       (insert (format " (process returned %d)" exit-status)))
844                     (insert "\n")))))))))
845
846 (defun notmuch-pick-process-filter (proc string)
847   "Process and filter the output of \"notmuch show\" (for pick)"
848   (let ((results-buf (process-buffer proc))
849         (parse-buf (process-get proc 'parse-buf))
850         (inhibit-read-only t)
851         done)
852     (if (not (buffer-live-p results-buf))
853         (delete-process proc)
854       (with-current-buffer parse-buf
855         ;; Insert new data
856         (save-excursion
857           (goto-char (point-max))
858           (insert string))
859         (notmuch-sexp-parse-partial-list 'notmuch-pick-insert-forest-thread
860                                          results-buf)))))
861
862 (defun notmuch-pick-worker (basic-query &optional query-context target buffer open-target)
863   (interactive)
864   (notmuch-pick-mode)
865   (setq notmuch-pick-basic-query basic-query)
866   (setq notmuch-pick-query-context query-context)
867   (setq notmuch-pick-buffer-name (buffer-name buffer))
868   (setq notmuch-pick-target-msg target)
869   (setq notmuch-pick-open-target open-target)
870
871   (erase-buffer)
872   (goto-char (point-min))
873   (let* ((search-args (concat basic-query
874                        (if query-context (concat " and (" query-context ")"))
875                        ))
876          (message-arg "--entire-thread"))
877     (if (equal (car (process-lines notmuch-command "count" search-args)) "0")
878         (setq search-args basic-query))
879     (let ((proc (notmuch-start-notmuch
880                  "notmuch-pick" buffer #'notmuch-pick-process-sentinel
881                  "show" "--body=false" "--format=sexp"
882                  message-arg search-args))
883           ;; Use a scratch buffer to accumulate partial output.
884           ;; This buffer will be killed by the sentinel, which
885           ;; should be called no matter how the process dies.
886           (parse-buf (generate-new-buffer " *notmuch pick parse*")))
887       (process-put proc 'parse-buf parse-buf)
888       (set-process-filter proc 'notmuch-pick-process-filter)
889       (set-process-query-on-exit-flag proc nil))))
890
891 (defun notmuch-pick (&optional query query-context target buffer-name open-target)
892   "Run notmuch pick with the given `query' and display the results.
893
894 The arguments are:
895   QUERY: the main query. This can be any query but in many cases will be
896       a single thread. If nil this is read interactively from the minibuffer.
897   QUERY-CONTEXT: is an additional term for the query. The query used
898       is QUERY and QUERY-CONTEXT unless that does not match any messages
899       in which case we fall back to just QUERY.
900   TARGET: A message ID (with the id: prefix) that will be made
901       current if it appears in the pick results.
902   BUFFER-NAME: the name of the buffer to show the pick tree. If
903       it is nil \"*notmuch-pick\" followed by QUERY is used.
904   OPEN-TARGET: If TRUE open the target message in the message pane."
905   (interactive "sNotmuch pick: ")
906   (if (null query)
907       (setq query (notmuch-read-query "Notmuch pick: ")))
908   (let ((buffer (get-buffer-create (generate-new-buffer-name
909                                     (or buffer-name
910                                         (concat "*notmuch-pick-" query "*")))))
911         (inhibit-read-only t))
912
913     (switch-to-buffer buffer)
914     ;; Don't track undo information for this buffer
915     (set 'buffer-undo-list t)
916
917     (notmuch-pick-worker query query-context target buffer open-target)
918
919     (setq truncate-lines t)))
920
921
922 ;; Set up key bindings from the rest of notmuch.
923 (define-key 'notmuch-search-mode-map "z" 'notmuch-pick)
924 (define-key 'notmuch-search-mode-map "Z" 'notmuch-pick-from-search-current-query)
925 (define-key 'notmuch-search-mode-map (kbd "M-RET") 'notmuch-pick-from-search-thread)
926 (define-key 'notmuch-hello-mode-map "z" 'notmuch-pick-from-hello)
927 (define-key 'notmuch-show-mode-map "z" 'notmuch-pick)
928 (define-key 'notmuch-show-mode-map "Z" 'notmuch-pick-from-show-current-query)
929 (notmuch-pick-setup-show-out)
930 (message "Initialised notmuch-pick")
931
932 (provide 'notmuch-pick)