From 7bf99d0b63f37c0d7578a54539dc3295a2e692f8 Mon Sep 17 00:00:00 2001 From: Mark Walters Date: Tue, 6 Nov 2012 23:14:41 +0000 Subject: [PATCH] Re: [PATCH] emacs: display tags in notmuch-show's header-line with links to search --- f3/8ccfab4852b4f7cef5aff30315f5419a0b9949 | 504 ++++++++++++++++++++++ 1 file changed, 504 insertions(+) create mode 100644 f3/8ccfab4852b4f7cef5aff30315f5419a0b9949 diff --git a/f3/8ccfab4852b4f7cef5aff30315f5419a0b9949 b/f3/8ccfab4852b4f7cef5aff30315f5419a0b9949 new file mode 100644 index 000000000..0000c927a --- /dev/null +++ b/f3/8ccfab4852b4f7cef5aff30315f5419a0b9949 @@ -0,0 +1,504 @@ +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 DD861431FB6 + for ; Tue, 6 Nov 2012 15:14:51 -0800 (PST) +X-Virus-Scanned: Debian amavisd-new at olra.theworths.org +X-Spam-Flag: NO +X-Spam-Score: -1.098 +X-Spam-Level: +X-Spam-Status: No, score=-1.098 tagged_above=-999 required=5 + tests=[DKIM_ADSP_CUSTOM_MED=0.001, FREEMAIL_FROM=0.001, + NML_ADSP_CUSTOM_MED=1.2, RCVD_IN_DNSWL_MED=-2.3] 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 SVr2ndUEQRMK for ; + Tue, 6 Nov 2012 15:14:50 -0800 (PST) +Received: from mail2.qmul.ac.uk (mail2.qmul.ac.uk [138.37.6.6]) + (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) + (No client certificate requested) + by olra.theworths.org (Postfix) with ESMTPS id C86C1431FAE + for ; Tue, 6 Nov 2012 15:14:49 -0800 (PST) +Received: from smtp.qmul.ac.uk ([138.37.6.40]) + by mail2.qmul.ac.uk with esmtp (Exim 4.71) + (envelope-from ) + id 1TVsLy-0005yQ-29; Tue, 06 Nov 2012 23:14:44 +0000 +Received: from 93-97-24-31.zone5.bethere.co.uk ([93.97.24.31] helo=localhost) + by smtp.qmul.ac.uk with esmtpsa (TLSv1:AES128-SHA:128) (Exim 4.69) + (envelope-from ) + id 1TVsLw-0005gV-W0; Tue, 06 Nov 2012 23:14:41 +0000 +From: Mark Walters +To: Damien Cassou , + notmuch mailing list +Subject: Re: [PATCH] emacs: display tags in notmuch-show's header-line with + links to search +In-Reply-To: <1352234344-28119-1-git-send-email-damien.cassou@gmail.com> +References: <1352234344-28119-1-git-send-email-damien.cassou@gmail.com> +User-Agent: Notmuch/0.14+94~gd1761fe (http://notmuchmail.org) Emacs/23.4.1 + (x86_64-pc-linux-gnu) +Date: Tue, 06 Nov 2012 23:14:41 +0000 +Message-ID: <87txt2z5lq.fsf@qmul.ac.uk> +MIME-Version: 1.0 +Content-Type: text/plain; charset=utf-8 +Content-Transfer-Encoding: quoted-printable +X-Sender-Host-Address: 93.97.24.31 +X-QM-SPAM-Info: Sender has good ham record. :) +X-QM-Body-MD5: 406d0455b9234758e2b1b4e1bad0115d (of first 20000 bytes) +X-SpamAssassin-Score: -1.8 +X-SpamAssassin-SpamBar: - +X-SpamAssassin-Report: The QM spam filters have analysed this message to + determine if it is + spam. We require at least 5.0 points to mark a message as spam. + This message scored -1.8 points. + Summary of the scoring: + * -2.3 RCVD_IN_DNSWL_MED RBL: Sender listed at http://www.dnswl.org/, + * medium trust + * [138.37.6.40 listed in list.dnswl.org] + * 0.0 FREEMAIL_FROM Sender email is commonly abused enduser mail + provider * (markwalters1009[at]gmail.com) + * 0.5 AWL AWL: From: address is in the auto white-list +X-QM-Scan-Virus: ClamAV says the message is clean +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: Tue, 06 Nov 2012 23:14:52 -0000 + + +Hi=20 + +This is not a full review: just a couple of thoughts. It basically seems +to work as expected. I am not quite sure what behaviour you would expect +in a couple of corner cases: + +1) what it the user toggles the display of matching messages (elide +mode)? Do you still want all tags from all messages including those not +visible? + +2) What about any tags from excluded messages? Should they show up? What +if they would be excluded but aren't because of the particular search? + + +On Tue, 06 Nov 2012, Damien Cassou wrote: +> 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 +++++++++++++++++++++++++++ + +I would go for tagger rather than tager (but others can disagree). + +> 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 in= +formation." +> (lambda (msg) (plist-get msg :id)) +> (notmuch-query-get-threads search-terms))) +>=20=20 +> +(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=3D)) +> + tag-lists))))) + +Couldn't you do this with notmuch-show-mapc and avoid the extra call to +notmuch? It also probably helps some cases of excluded tags and elide +mode. + + +If for some reason the query is better than I think you work +to remove the thread: from the thread-id below and then add it back in +here? + + +> + +> (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) +>=20=20 +> (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))) +>=20=20 +> +(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 ":"))) +> + + +Here is where the thread: is removed. + +Anyway just some thoughts! + +Best wishes + +Mark + + +> (defun notmuch-show-build-buffer () +> (let ((inhibit-read-only t)) +>=20=20 +> @@ -1077,11 +1084,18 @@ function is used." +>=20=20 +> (jit-lock-register #'notmuch-show-buttonise-links) +>=20=20 +> - ;; 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)))) +>=20=20 +> +(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. +>=20=20 +> 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 =C2=A9 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) +> +(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 +>=20=20 +> +test_begin_subtest "Extracting all tags from a thread" +> +add_message \ +> + '[subject]=3D"Extracting all tags from a thread"' \ +> + '[body]=3D"body 1"' +> +parent=3D${gen_msg_id} +> +add_message \ +> + '[subject]=3D"Extracting all tags from a thread"' \ +> + '[body]=3D"body 2"' \ +> + "[in-reply-to]=3D\<$parent\>" +> +add_message \ +> + '[subject]=3D"Extracting all tags from a thread"' \ +> + '[body]=3D"body 3"' \ +> + "[in-reply-to]=3D\<$parent\>" +> +latest=3D${gen_msg_id} +> +# Extract the thread-id from one of the emails +> +thread_id=3D$(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]=3D"foo bar"' \ +> + '[body]=3D"body 1"' +> +parent=3D${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=3D$(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-form= +at)) +> + t +> + \"The tag mytagfoo was not in the header-line-format\")" +>=20=20 +> 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 +> +;; 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 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 +> --=20 +> 1.7.10.4 +> +> _______________________________________________ +> notmuch mailing list +> notmuch@notmuchmail.org +> http://notmuchmail.org/mailman/listinfo/notmuch -- 2.26.2