From: Damien Cassou <damien.cassou@gmail.com>
To: notmuch mailing list <notmuch@notmuchmail.org>
Subject: [PATCH v2] emacs: display tags in notmuch-show with links
Date: Sat, 10 Nov 2012 17:41:59 +0100
Message-Id: <1352565719-12397-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

This patch obsoletes
id:1352234344-28119-1-git-send-email-damien.cassou@gmail.com

This patch makes clickable all tags that appear in notmuch-show
buffers. Each tag is a link to open a new notmuch-search buffer for
this tag. Additionally, the buffer's header-line now shows the
thread's tags (also clickable).

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.
Jonas gave me the authorization to include the package in notmuch, but
only if the package is first searched in the existing `load-path'. See
this thread:
id:CA+y5ggiGrAcicQLeskaXFoxYyJQVVXZ1VRX=XS8zPFR9_mBFxA@mail.gmail.com

With respect to v1, I took care of the comments you made:
- Renamed tager to tagger;
- Avoided an additional call to notmuch by reading existing data in
  the buffer with `notmuch-show-mapc';
- As a result of previous point, a thread's tags now equals the union
  of the emails' tags that are visible;
- Stopped stripping "thread:" from the thread-id to add it back
  later.

With respect to v1, I added the following:
- Each label on each message is now clickable;
- Moved header-button.el to fallback-libs/ and only load this one when
  it is not already in the `load-path'.

You can follow this patch series on
https://github.com/DamienCassou/notmuch/tree/labeler-integration

Signed-off-by: Damien Cassou <damien.cassou@gmail.com>
---
 emacs/fallback-libs/.nosearch        |    1 +
 emacs/fallback-libs/header-button.el |  138 ++++++++++++++++++++++++++++++++++
 emacs/notmuch-show.el                |   33 ++++++--
 emacs/notmuch-tagger.el              |  129 +++++++++++++++++++++++++++++++
 test/emacs                           |   61 +++++++++++++++
 5 files changed, 355 insertions(+), 7 deletions(-)
 create mode 100644 emacs/fallback-libs/.nosearch
 create mode 100644 emacs/fallback-libs/header-button.el
 create mode 100644 emacs/notmuch-tagger.el

diff --git a/emacs/fallback-libs/.nosearch b/emacs/fallback-libs/.nosearch
new file mode 100644
index 0000000..0a01dc9
--- /dev/null
+++ b/emacs/fallback-libs/.nosearch
@@ -0,0 +1 @@
+This file prevents Emacs from adding the directory to the `load-path'.
diff --git a/emacs/fallback-libs/header-button.el b/emacs/fallback-libs/header-button.el
new file mode 100644
index 0000000..05f6f32
--- /dev/null
+++ b/emacs/fallback-libs/header-button.el
@@ -0,0 +1,138 @@
+;;; 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 use `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."
+  ;; Older versions only supported `:action' but button.el uses
+  ;; `action' instead.  Now we support both and query `:action'
+  ;; first because `action' defaults to function `ignore'.
+  (funcall (or (header-button-get button :action)
+               (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
diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el
index d061367..6f38381 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-tagger)
 
 (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))
 (declare-function notmuch-fontify-headers "notmuch" nil)
@@ -430,10 +431,11 @@ message at DEPTH in the current thread."
 	    (notmuch-show-clean-address (plist-get headers :From))
 	    " ("
 	    date
-	    ") ("
-	    (propertize (mapconcat 'identity tags " ")
-			'face 'notmuch-tag-face)
-	    ")\n")
+	    ") "
+	    (propertize
+	     (format-mode-line (notmuch-tagger-present-tags tags))
+	     'face 'notmuch-tag-face)
+	    "\n")
     (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face)))
 
 (defun notmuch-show-insert-header (header header-value)
@@ -1082,11 +1084,28 @@ 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-thread-tags ()
+  "Return the list of tags for the current thread."
+  (let ((tags (list)))
+    (notmuch-show-mapc (lambda ()
+			 (mapcar (lambda (elt)
+				   ;; Avoid adding duplicate tags
+				   (add-to-list 'tags elt))
+				 (notmuch-show-get-tags))))
+    tags))
+
+(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
+	  (list
+	   thread-subject
+	   " "
+	   (notmuch-tagger-present-tags (notmuch-show-thread-tags) t)))))
+
 (defun notmuch-show-capture-state ()
   "Capture the state of the current buffer.
 
diff --git a/emacs/notmuch-tagger.el b/emacs/notmuch-tagger.el
new file mode 100644
index 0000000..e825df5
--- /dev/null
+++ b/emacs/notmuch-tagger.el
@@ -0,0 +1,129 @@
+;; notmuch-tagger.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)
+
+(or (require 'header-button nil t)
+    (let ((load-path
+           (cons (expand-file-name
+                  "fallback-libs"
+                  (file-name-directory (or load-file-name buffer-file-name)))
+                 load-path)))
+      (require 'header-button)))
+
+(defun notmuch-tagger-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-tagger-goto-target (target)
+  "Show a `notmuch-search' buffer for the TARGET tag."
+  (notmuch-search (concat "tag:" target)))
+
+(defun notmuch-tagger-headerline-button-action (button)
+  "Open `notmuch-search' for the tag referenced by BUTTON."
+  (let ((tag (header-button-get button 'notmuch-tagger-tag)))
+    (notmuch-tagger-goto-target tag)))
+
+(defun notmuch-tagger-body-button-action (button)
+  "Open `notmuch-search' for the tag referenced by BUTTON."
+  (let ((tag (button-get button 'notmuch-tagger-tag)))
+    (notmuch-tagger-goto-target tag)))
+
+(define-button-type 'notmuch-tagger-headerline-button-type
+  'supertype 'header
+  'action    #'notmuch-tagger-headerline-button-action
+  'follow-link t)
+
+(define-button-type 'notmuch-tagger-body-button-type
+  'action    #'notmuch-tagger-body-button-action
+  'follow-link t)
+
+(defun notmuch-tagger-make-headerline-link (target)
+  "Return a property list that presents a link to TARGET.
+
+TARGET is a notmuch tag.
+The returned property list will only work in the header-line."
+  (header-button-format
+   target
+   :type 'notmuch-tagger-headerline-button-type
+   'notmuch-tagger-tag target
+   'help-echo (format "%s: Search other messages like this" target)))
+
+(defun notmuch-tagger-make-body-link (target)
+  "Return a property list that presents a link to TARGET.
+
+TARGET is a notmuch tag.
+The returned property list will work everywhere except in the
+header-line."
+  (let ((button (copy-sequence target)))
+    (make-text-button
+     button nil
+     'type 'notmuch-tagger-body-button-type
+     'notmuch-tagger-tag target
+     'help-echo (format "%s: Search other messages like this" target))
+    button))
+
+(defun notmuch-tagger-make-link (target headerline)
+"Return a property list that presents a link to TARGET.
+
+TARGET is a notmuch tag.
+
+If HEADERLINE is non-nil the returned list will be ready for
+inclusion in the buffer's header-line. HEADERLINE must be nil in
+all other cases."
+  (if headerline
+      (notmuch-tagger-make-headerline-link target)
+    (notmuch-tagger-make-body-link target)))
+
+(defun notmuch-tagger-format-tags (tags &optional headerline)
+  "Return a format list for TAGS suitable for use in header line.
+See Info node `(elisp)Mode Line Format' for more information.
+
+If HEADERLINE is non-nil the returned list will be ready for
+inclusion in the buffer's header-line. HEADERLINE must be nil in
+all other cases."
+  (mapcar
+   (lambda (tag) (notmuch-tagger-make-link tag headerline))
+   tags))
+
+(defun notmuch-tagger-present-tags (tags &optional headerline)
+  "Return a property list which nicely presents all TAGS.
+
+If HEADERLINE is non-nil the returned list will be ready for
+inclusion in the buffer's header-line. HEADERLINE must be nil in
+all other cases."
+  (list
+   "("
+   (notmuch-tagger-separate-elems (notmuch-tagger-format-tags tags headerline) " ")
+   ")"))
+
+(provide 'notmuch-tagger)
+;;; notmuch-tagger.el ends here
diff --git a/test/emacs b/test/emacs
index 44f641e..ecdc841 100755
--- a/test/emacs
+++ b/test/emacs
@@ -820,5 +820,66 @@ 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 \
+    "(notmuch-show \"thread:${thread_id}\")
+     (let ((output (notmuch-show-thread-tags))
+           (expected '(\"inbox\" \"mytagfoo\" \"unread\")))
+      (notmuch-test-expect-equal
+         (sort output #'string<)
+         (sort expected #'string<)))"
+
+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_begin_subtest "The tags of notmuch-show emails are clickable"
+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}\")
+    (goto-char (point-min))
+    (re-search-forward \"mytagfoo\")
+    (backward-char) ;; to be 'in' the tag
+    (unless (eq major-mode 'notmuch-show-mode)
+       (error \"We must be in notmch-show at this point but we are in %s.\" major-mode))
+    (push-button) ;; simulate a press on the RET key
+    (if (eq major-mode 'notmuch-search-mode)
+        t
+       (format \"We must be in notmch-search at this point but we are in %s.\" major-mode))"
 
 test_done
-- 
1.7.10.4