From: Damien Cassou <damien.cassou@gmail.com>
To: notmuch mailing list <notmuch@notmuchmail.org>
Subject: [PATCH] emacs: display tags in notmuch-show's header-line with links to search
Date: Tue,  6 Nov 2012 21:39:04 +0100
Message-Id: <1352234344-28119-1-git-send-email-damien.cassou@gmail.com>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Precedence: list

In notmuch-show, the header-line was previously only showing the
subject of the current thread. With this commit, the header-line now
additionally shows all the tags associated to the thread. Each tag is
a link to open a new notmuch-search buffer for this tag.

This patch is the first one of an upcoming series whose goal is to
integrate notmuch-labeler into notmuch. See the following for more
details:
https://github.com/DamienCassou/notmuch-labeler

This patch includes header-button.el, a package contributed by Jonas
Bernoulli that fixes a limitation of the button.el Emacs library.

ATTENTION: Because I didn't get the permission of Jonas Bernoulli yet,
I recommend *not* to integrate this patch into notmuch right now.
Please see this email as a call for review.

Note: This code breaks the two unit-tests "Do not call notmuch for
non-inlinable..." that are in test/emacs. This is because these tests
expect that notmuch would be called only once, but my patch forces an
additional call to notmuch to get the list of tags for the current
thread.

---
 emacs/header-button.el |  133 ++++++++++++++++++++++++++++++++++++++++++++++++
 emacs/notmuch-query.el |   16 ++++++
 emacs/notmuch-show.el  |   20 ++++++--
 emacs/notmuch-tager.el |   76 +++++++++++++++++++++++++++
 test/emacs             |   37 ++++++++++++++
 5 files changed, 279 insertions(+), 3 deletions(-)
 create mode 100644 emacs/header-button.el
 create mode 100644 emacs/notmuch-tager.el

diff --git a/emacs/notmuch-query.el b/emacs/notmuch-query.el
index d66baea..c1d2ec9 100644
--- a/emacs/notmuch-query.el
+++ b/emacs/notmuch-query.el
@@ -81,4 +81,20 @@ See the function notmuch-query-get-threads for more information."
    (lambda (msg) (plist-get msg :id))
    (notmuch-query-get-threads search-terms)))
 
+(defun notmuch-query-thread-tags-from-id (thread-id)
+  "Return the tags of thread whose id is THREAD-ID.
+The thread tags are the union of the tags of emails in the
+thread."
+  (let ((tag-lists
+	 (notmuch-query-map-forest
+	  (lambda (msg) (plist-get msg :tags))
+	  (car (notmuch-query-get-threads
+		(list (concat "thread:" thread-id)))))))
+    (case (length tag-lists)
+      (0 nil)
+      (1 (car tag-lists))
+      (otherwise (reduce (lambda (l1 l2)
+			   (union l1 l2 :test 'string=))
+			 tag-lists)))))
+
 (provide 'notmuch-query)
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index f273eb4..3a09998 100644
--- a/emacs/notmuch-show.el
+++ b/emacs/notmuch-show.el
@@ -36,6 +36,7 @@
 (require 'notmuch-mua)
 (require 'notmuch-crypto)
 (require 'notmuch-print)
+(require 'notmuch-tager)
 
 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
 (declare-function notmuch-fontify-headers "notmuch" nil)
@@ -1048,6 +1049,12 @@ function is used."
     (notmuch-show-goto-first-wanted-message)
     (current-buffer)))
 
+(defun notmuch-show-thread-id ()
+  "Return the raw thread id of the currently visited thread."
+  ;; `notmuch-show-thread-id' is of the form "thread:00001212" so we
+  ;; have to extract the second part.
+  (second (split-string notmuch-show-thread-id ":")))
+
 (defun notmuch-show-build-buffer ()
   (let ((inhibit-read-only t))
 
@@ -1077,11 +1084,18 @@ function is used."
 
       (jit-lock-register #'notmuch-show-buttonise-links)
 
-      ;; Set the header line to the subject of the first message.
-      (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))
-
+      (notmuch-show-update-header-line)
       (run-hooks 'notmuch-show-hook))))
 
+(defun notmuch-show-update-header-line ()
+  "Make the header-line show the thread's subject and tags."
+  (let ((thread-subject (notmuch-show-strip-re (notmuch-show-get-subject))))
+    (setq header-line-format
+	  (cons
+	   thread-subject
+	   (notmuch-tager-present-tags
+	    (notmuch-query-thread-tags-from-id (notmuch-show-thread-id)))))))
+
 (defun notmuch-show-capture-state ()
   "Capture the state of the current buffer.
 
diff --git a/emacs/notmuch-tager.el b/emacs/notmuch-tager.el
new file mode 100644
index 0000000..1f83e29
--- /dev/null
+++ b/emacs/notmuch-tager.el
@@ -0,0 +1,76 @@
+;; notmuch-tager.el --- Library to show labels as links
+;;
+;; Copyright © Damien Cassou
+;;
+;; This file is part of Notmuch.
+;;
+;; Notmuch is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Notmuch is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Notmuch.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; Authors: Damien Cassou <damien.cassou@gmail.com>
+;;; Commentary:
+;;
+;;; Code:
+;;
+
+(require 'button)
+(require 'header-button)
+
+(defun notmuch-tager-separate-elems (list sep)
+  "Return a list with all elements of LIST separated by SEP."
+  (let ((first t)
+        (res nil))
+    (dolist (elt (reverse list) res)
+      (unless first
+        (push sep res))
+      (setq first nil)
+      (push elt res))))
+
+(defun notmuch-tager-goto-target (target)
+  "Show a `notmuch-search' buffer for the TARGET tag."
+  (notmuch-search (concat "tag:" target)))
+
+(defun notmuch-tager-button-action (button)
+  "Open `notmuch-search' for the tag referenced by BUTTON."
+  (let ((tag (header-button-get button :notmuch-tager-tag)))
+    (notmuch-tager-goto-target tag)))
+
+(define-button-type 'notmuch-tager-button-type
+  :supertype 'header
+  :action    'notmuch-tager-button-action
+  :follow-link t)
+
+(defun notmuch-tager-make-link (target)
+  "Return a property list that presents a link to TARGET.
+
+TARGET is a notmuch tag."
+  (header-button-format
+   target
+   :type 'notmuch-tager-button-type
+   :notmuch-tager-tag target
+   :help-echo (format "%s: Search other messages like this" target)))
+
+(defun notmuch-tager-format-tags (tags)
+  "Return a format list for TAGS suitable for use in header line.
+See Info node `(elisp)Mode Line Format' for more information."
+  (mapcar 'notmuch-tager-make-link tags))
+
+(defun notmuch-tager-present-tags (tags)
+  "Return a property list which nicely presents all TAGS."
+  (list
+   " ("
+   (notmuch-tager-separate-elems (notmuch-tager-format-tags tags) ", ")
+   ")"))
+
+(provide 'notmuch-tager)
+;;; notmuch-tager.el ends here
diff --git a/test/emacs b/test/emacs
index 44f641e..c062e4d 100755
--- a/test/emacs
+++ b/test/emacs
@@ -820,5 +820,42 @@ Date: Fri, 05 Jan 2001 15:43:57 +0000
 EOF
 test_expect_equal_file OUTPUT EXPECTED
 
+test_begin_subtest "Extracting all tags from a thread"
+add_message \
+    '[subject]="Extracting all tags from a thread"' \
+    '[body]="body 1"'
+parent=${gen_msg_id}
+add_message \
+    '[subject]="Extracting all tags from a thread"' \
+    '[body]="body 2"' \
+    "[in-reply-to]=\<$parent\>"
+add_message \
+    '[subject]="Extracting all tags from a thread"' \
+    '[body]="body 3"' \
+    "[in-reply-to]=\<$parent\>"
+latest=${gen_msg_id}
+# Extract the thread-id from one of the emails
+thread_id=$(notmuch search id:${latest} | sed -e "s/thread:\([a-f0-9]*\).*/\1/")
+# Add tag "mytagfoo" to one of the emails
+notmuch tag +mytagfoo id:${latest}
+test_emacs_expect_t \
+    "(let ((output (notmuch-query-thread-tags-from-id \"${thread_id}\"))
+           (expected '(\"inbox\" \"mytagfoo\" \"unread\")))
+      (notmuch-test-expect-equal output expected))"
+
+test_begin_subtest "The tags appear in the header-line of notmuch-show"
+add_message \
+    '[subject]="foo bar"' \
+    '[body]="body 1"'
+parent=${gen_msg_id}
+# Add tag "mytagfoo" to one of the emails
+notmuch tag +mytagfoo id:${parent}
+# Extract the thread-id from one of the emails
+thread_id=$(notmuch search id:${latest} | sed -e "s/thread:\([a-f0-9]*\).*/\1/")
+test_emacs_expect_t \
+    "(notmuch-show \"thread:${thread_id}\")
+     (if (string-match-p \"mytagfoo\" (format-mode-line header-line-format))
+         t
+       \"The tag mytagfoo was not in the header-line-format\")"
 
 test_done

diff --git a/emacs/header-button.el b/emacs/header-button.el
new file mode 100644
index 0000000..9b0cbcf
--- /dev/null
+++ b/emacs/header-button.el
@@ -0,0 +1,133 @@
+;;; header-button.el --- clickable buttons in header lines
+
+;; Copyright (C) 2010-2012  Jonas Bernoulli
+
+;; Author: Jonas Bernoulli <jonas@bernoul.li>
+;; Created: 20100604
+;; Version: 0.2.2
+;; Homepage: https://github.com/tarsius/header-button
+;; Keywords: extensions
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package extends `button' by adding support for adding buttons to
+;; the header line.  Since the header line is very limited compared to a
+;; buffer most of the functionality provided by `button' is not available
+;; for buttons in the header line.
+
+;; While `button' provides the function `insert-button' (as well as
+;; others) to insert a button into a buffer at point, something similar
+;; can't be done here, due to the lack of point in header lines.
+
+;; Instead us `header-button-format' like this:
+;;
+;; (setq header-line-format
+;;       (concat "Here's a button: "
+;;               (header-button-format "Click me!" :action 'my-action)))
+
+;; Like with `button' you can create your own derived button types:
+;;
+;; (define-button-type 'my-header
+;;   :supertype 'header
+;;   :action 'my-action)
+;;
+;; (setq header-line-format
+;;       (concat (header-button-format "Click me!" :action 'my-action) " "
+;;               (header-button-format "No me!" :type 'my-header)))
+
+;; The function associated with `:action' is called with the button plist
+;; as only argument.  Do no use `plist-get' to extract a value from it.
+;; Instead use `header-button-get' which will also extract values stored
+;; in it's type.
+;;
+;; (defun my-action (button)
+;;   (message "This button labeled `%s' belongs to category `%s'"
+;;            (header-button-label button)
+;;            (header-button-get button 'category)))
+
+;;; Code:
+
+(require 'button)
+
+(defvar header-button-map
+  (let ((map (make-sparse-keymap)))
+    ;; $$$ follow-link does not work here
+    (define-key map [header-line mouse-1] 'header-button-push)
+    (define-key map [header-line mouse-2] 'header-button-push)
+    map)
+  "Keymap used by buttons in header lines.")
+
+(define-button-type 'header
+  'keymap header-button-map
+  'help-echo (purecopy "mouse-1: Push this button"))
+
+(defun header-button-get (button prop)
+  "Get the property of header button BUTTON named PROP."
+  (let ((entry (plist-member button prop)))
+    (if entry
+        (cadr entry)
+      (get (plist-get button 'category) prop))))
+
+(defun header-button-label (button)
+  "Return header button BUTTON's text label."
+  (plist-get button 'label))
+
+(defun header-button-format (label &rest properties)
+  "Format a header button string with the label LABEL.
+The remaining arguments form a sequence of PROPERTY VALUE pairs,
+specifying properties to add to the button.
+In addition, the keyword argument :type may be used to specify a
+button-type from which to inherit other properties; see
+`define-button-type'.
+
+To actually create the header button set the value of variable
+`header-line-format' to the string returned by this function
+\(or a string created by concatenating that string with others."
+  (let ((type-entry (or (plist-member properties 'type)
+                        (plist-member properties :type))))
+    (when (plist-get properties 'category)
+      (error "Button `category' property may not be set directly"))
+    (if (null type-entry)
+        (setq properties
+              (cons 'category
+                    (cons (button-category-symbol 'header) properties)))
+      (setcar type-entry 'category)
+      (setcar (cdr type-entry)
+              (button-category-symbol (car (cdr type-entry)))))
+    (apply #'propertize label
+           (nconc (list 'button (list t) 'label label) properties))))
+
+(defun header-button-activate (button)
+  "Call header button BUTTON's `:action' property."
+  (funcall (header-button-get button :action) button))
+
+(defun header-button-push ()
+  "Perform the action specified by the pressed header button."
+  (interactive)
+  (let* ((posn (event-start last-command-event))
+         (object (posn-object posn))
+         (buffer (window-buffer (posn-window posn)))
+         (button (text-properties-at (cdr object) (car object))))
+    (with-current-buffer buffer
+      (header-button-activate button))))
+
+(provide 'header-button)
+;; Local Variables:
+;; indent-tabs-mode: nil
+;; End:
+;;; header-button.el ends here
-- 
1.7.10.4