[PATCH v2] emacs: display tags in notmuch-show with links
Damien Cassou
damien.cassou at gmail.com
Sat Nov 10 08:41:59 PST 2012
This patch obsoletes
id:1352234344-28119-1-git-send-email-damien.cassou at 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 at 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 at 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 at 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 at 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
More information about the notmuch
mailing list