From: Damien Cassou Date: Sat, 10 Nov 2012 16:41:59 +0000 (+0100) Subject: [PATCH v2] emacs: display tags in notmuch-show with links X-Git-Url: http://git.tremily.us/gitweb.cgi?a=commitdiff_plain;h=00554bba5d77ae17d14e29cfdf68204571f699b4;p=notmuch-archives.git [PATCH v2] emacs: display tags in notmuch-show with links --- diff --git a/fc/ddcc671b99b4265d9064361a1709876574f48c b/fc/ddcc671b99b4265d9064361a1709876574f48c new file mode 100644 index 000000000..9b81cff4f --- /dev/null +++ b/fc/ddcc671b99b4265d9064361a1709876574f48c @@ -0,0 +1,534 @@ +Return-Path: +X-Original-To: notmuch@notmuchmail.org +Delivered-To: notmuch@notmuchmail.org +Received: from localhost (localhost [127.0.0.1]) + by olra.theworths.org (Postfix) with ESMTP id EA7A3431FB6 + for ; Sat, 10 Nov 2012 08:42:35 -0800 (PST) +X-Virus-Scanned: Debian amavisd-new at olra.theworths.org +X-Spam-Flag: NO +X-Spam-Score: 1.7 +X-Spam-Level: * +X-Spam-Status: No, score=1.7 tagged_above=-999 required=5 + tests=[DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, + FREEMAIL_FROM=0.001, FREEMAIL_REPLY=2.499, RCVD_IN_DNSWL_LOW=-0.7] + autolearn=disabled +Received: from olra.theworths.org ([127.0.0.1]) + by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024) + with ESMTP id 0sUuV0LU3a+5 for ; + Sat, 10 Nov 2012 08:42:34 -0800 (PST) +Received: from mail-wi0-f179.google.com (mail-wi0-f179.google.com + [209.85.212.179]) (using TLSv1 with cipher RC4-SHA (128/128 bits)) + (No client certificate requested) + by olra.theworths.org (Postfix) with ESMTPS id C4770431FAF + for ; Sat, 10 Nov 2012 08:42:33 -0800 (PST) +Received: by mail-wi0-f179.google.com with SMTP id hm6so1027954wib.2 + for ; Sat, 10 Nov 2012 08:42:32 -0800 (PST) +DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; + h=from:to:cc:subject:date:message-id:x-mailer:mime-version + :content-type:content-transfer-encoding; + bh=SokKGH5nL2A7mAwfJwWFkf3dGi1c6ohOxYnwTr9Cr/w=; + b=TK6sze1FbLOckGUlw+NMdx2Kytmz0sBCuYCrluwNfVBZtIjRLC10MvmbT37OLUYfHH + 5oX7RoMPbJBP1sD3KuYedWkRdMb+dmtwiyRjw1Bpxatqvg3CGOofB0LlXP1FwWTqI29Y + 2P4gbvN9XezWDiAbyWMlhIRJGPuWAo8x9cXwu/OFQgmwvO0lRf//N49n3BWwwv643krb + j9PssL9rGAtaaGu5LK9Ha80zfoTbxZ799/bfCMT9n9WrGqBTd9NyBY7n2cem1gFxCTvX + hGb43DiHsjvaFfr13x2hhBjSFc2wMw0dQ1uWvvjXqJ9vPzg/VqbhNh5m45o+yGUcHScV + KBWA== +Received: by 10.180.97.35 with SMTP id dx3mr7785198wib.14.1352565752453; + Sat, 10 Nov 2012 08:42:32 -0800 (PST) +Received: from localhost.localdomain (ble59-4-82-228-190-150.fbx.proxad.net. + [82.228.190.150]) + by mx.google.com with ESMTPS id i6sm6952373wix.5.2012.11.10.08.42.31 + (version=TLSv1/SSLv3 cipher=OTHER); + Sat, 10 Nov 2012 08:42:31 -0800 (PST) +From: Damien Cassou +To: notmuch mailing list +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> +X-Mailer: git-send-email 1.7.10.4 +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit +X-BeenThere: notmuch@notmuchmail.org +X-Mailman-Version: 2.1.13 +Precedence: list +List-Id: "Use and development of the notmuch mail system." + +List-Unsubscribe: , + +List-Archive: +List-Post: +List-Help: +List-Subscribe: , + +X-List-Received-Date: Sat, 10 Nov 2012 16:42:36 -0000 + +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 +--- + 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 ++;; 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 . ++ ++;;; 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 . ++;; ++;; Authors: Damien Cassou ++;;; 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 +