path: root/emacs/notmuch-tag.el

;;; notmuch-tag.el --- tag messages within emacs
;;
;; Copyright © Damien Cassou
;; Copyright © Carl Worth
;;
;; 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 <https://www.gnu.org/licenses/>.
;;
;; Authors: Carl Worth <cworth@cworth.org>
;;          Damien Cassou <damien.cassou@gmail.com>

;;; Code:

(require 'cl-lib)
(eval-when-compile
  (require 'pcase))

(require 'crm)

(require 'notmuch-lib)

(declare-function notmuch-search-tag "notmuch"
		  (tag-changes &optional beg end only-matched))
(declare-function notmuch-show-tag "notmuch-show" (tag-changes))
(declare-function notmuch-tree-tag "notmuch-tree" (tag-changes))
(declare-function notmuch-jump "notmuch-jump" (action-map prompt))

(define-widget 'notmuch-tag-key-type 'list
  "A single key tagging binding."
  :format "%v"
  :args '((list :inline t
		:format "%v"
		(key-sequence :tag "Key")
		(radio :tag "Tag operations"
		       (repeat :tag "Tag list"
			       (string :format "%v" :tag "change"))
		       (variable :tag "Tag variable"))
		(string :tag "Name"))))

(defcustom notmuch-tagging-keys
  `((,(kbd "a") notmuch-archive-tags "Archive")
    (,(kbd "u") notmuch-show-mark-read-tags "Mark read")
    (,(kbd "f") ("+flagged") "Flag")
    (,(kbd "s") ("+spam" "-inbox") "Mark as spam")
    (,(kbd "d") ("+deleted" "-inbox") "Delete"))
  "A list of keys and corresponding tagging operations.

For each key (or key sequence) you can specify a sequence of
tagging operations to apply, or a variable which contains a list
of tagging operations such as `notmuch-archive-tags'. The final
element is a name for this tagging operation. If the name is
omitted or empty then the list of tag changes, or the variable
name is used as the name.

The key `notmuch-tag-jump-reverse-key' (k by default) should not
be used (either as a key, or as the start of a key sequence) as
it is already bound: it switches the menu to a menu of the
reverse tagging operations. The reverse of a tagging operation is
the same list of individual tag-ops but with `+tag` replaced by
`-tag` and vice versa.

If setting this variable outside of customize then it should be a
list of triples (lists of three elements). Each triple should be
of the form (key-binding tagging-operations name). KEY-BINDING
can be a single character or a key sequence; TAGGING-OPERATIONS
should either be a list of individual tag operations each of the
form `+tag` or `-tag`, or the variable name of a variable that is
a list of tagging operations; NAME should be a name for the
tagging operation, if omitted or empty than then name is taken
from TAGGING-OPERATIONS."
  :tag "List of tagging bindings"
  :type '(repeat notmuch-tag-key-type)
  :group 'notmuch-tag)

(define-widget 'notmuch-tag-format-type 'lazy
  "Customize widget for notmuch-tag-format and friends."
  :type '(alist :key-type (regexp :tag "Tag")
		:extra-offset -3
		:value-type
		(radio :format "%v"
		       (const :tag "Hidden" nil)
		       (set :tag "Modified"
			    (string :tag "Display as")
			    (list :tag "Face" :extra-offset -4
				  (const :format "" :inline t
					 (notmuch-apply-face tag))
				  (list :format "%v"
					(const :format "" quote)
					custom-face-edit))
			    (list :format "%v" :extra-offset -4
				  (const :format "" :inline t
					 (notmuch-tag-format-image-data tag))
				  (choice :tag "Image"
					  (const :tag "Star"
						 (notmuch-tag-star-icon))
					  (const :tag "Empty star"
						 (notmuch-tag-star-empty-icon))
					  (const :tag "Tag"
						 (notmuch-tag-tag-icon))
					  (string :tag "Custom")))
			    (sexp :tag "Custom")))))

(defface notmuch-tag-unread
  '((t :foreground "red"))
  "Default face used for the unread tag.

Used in the default value of `notmuch-tag-formats`."
  :group 'notmuch-faces)

(defface notmuch-tag-flagged
  '((((class color)
      (background dark))
     (:foreground "LightBlue1"))
    (((class color)
      (background light))
     (:foreground "blue")))
  "Face used for the flagged tag.

Used in the default value of `notmuch-tag-formats`."
  :group 'notmuch-faces)

(defcustom notmuch-tag-formats
  '(("unread" (propertize tag 'face 'notmuch-tag-unread))
    ("flagged" (propertize tag 'face 'notmuch-tag-flagged)
     (notmuch-tag-format-image-data tag (notmuch-tag-star-icon))))
  "Custom formats for individual tags.

This is an association list that maps from tag name regexps to
lists of formatting expressions.  The first entry whose car
regexp-matches a tag will be used to format that tag.  The regexp
is implicitly anchored, so to match a literal tag name, just use
that tag name (if it contains special regexp characters like
\".\" or \"*\", these have to be escaped).  The cdr of the
matching entry gives a list of Elisp expressions that modify the
tag.  If the list is empty, the tag will simply be hidden.
Otherwise, each expression will be evaluated in order: for the
first expression, the variable `tag' will be bound to the tag
name; for each later expression, the variable `tag' will be bound
to the result of the previous expression.  In this way, each
expression can build on the formatting performed by the previous
expression.  The result of the last expression will displayed in
place of the tag.

For example, to replace a tag with another string, simply use
that string as a formatting expression.  To change the foreground
of a tag to red, use the expression
  (propertize tag 'face '(:foreground \"red\"))

See also `notmuch-tag-format-image', which can help replace tags
with images."
  :group 'notmuch-search
  :group 'notmuch-show
  :group 'notmuch-faces
  :type 'notmuch-tag-format-type)

(defface notmuch-tag-deleted
  '((((class color) (supports :strike-through "red")) :strike-through "red")
    (t :inverse-video t))
  "Face used to display deleted tags.

Used in the default value of `notmuch-tag-deleted-formats`."
  :group 'notmuch-faces)

(defcustom notmuch-tag-deleted-formats
  '(("unread" (notmuch-apply-face bare-tag `notmuch-tag-deleted))
    (".*" (notmuch-apply-face tag `notmuch-tag-deleted)))
  "Custom formats for tags when deleted.

For deleted tags the formats in `notmuch-tag-formats` are applied
first and then these formats are applied on top; that is `tag'
passed to the function is the tag with all these previous
formattings applied. The formatted can access the original
unformatted tag as `bare-tag'.

By default this shows deleted tags with strike-through in red,
unless strike-through is not available (e.g., emacs is running in
a terminal) in which case it uses inverse video. To hide deleted
tags completely set this to
  '((\".*\" nil))

See `notmuch-tag-formats' for full documentation."
  :group 'notmuch-show
  :group 'notmuch-faces
  :type 'notmuch-tag-format-type)

(defface notmuch-tag-added
  '((t :underline "green"))
  "Default face used for added tags.

Used in the default value for `notmuch-tag-added-formats`."
  :group 'notmuch-faces)

(defcustom notmuch-tag-added-formats
  '((".*" (notmuch-apply-face tag 'notmuch-tag-added)))
  "Custom formats for tags when added.

For added tags the formats in `notmuch-tag-formats` are applied
first and then these formats are applied on top.

To disable special formatting of added tags, set this variable to
nil.

See `notmuch-tag-formats' for full documentation."
  :group 'notmuch-show
  :group 'notmuch-faces
  :type 'notmuch-tag-format-type)

(defun notmuch-tag-format-image-data (tag data)
  "Replace TAG with image DATA, if available.

This function returns a propertized string that will display image
DATA in place of TAG.This is designed for use in
`notmuch-tag-formats'.

DATA is the content of an SVG picture (e.g., as returned by
`notmuch-tag-star-icon')."
  (propertize tag 'display
	      `(image :type svg
		      :data ,data
		      :ascent center
		      :mask heuristic)))

(defun notmuch-tag-star-icon ()
  "Return SVG data representing a star icon.
This can be used with `notmuch-tag-format-image-data'."
  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\">
  <g transform=\"translate(-242.81601,-315.59635)\">
    <path
       d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
       transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
       style=\"fill:#ffff00;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
  </g>
</svg>")

(defun notmuch-tag-star-empty-icon ()
  "Return SVG data representing an empty star icon.
This can be used with `notmuch-tag-format-image-data'."
  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\">
  <g transform=\"translate(-242.81601,-315.59635)\">
    <path
       d=\"m 290.25762,334.31206 -17.64143,-11.77975 -19.70508,7.85447 5.75171,-20.41814 -13.55925,-16.31348 21.19618,-0.83936 11.325,-17.93675 7.34825,19.89939 20.55849,5.22795 -16.65471,13.13786 z\"
       transform=\"matrix(0.2484147,-0.02623394,0.02623394,0.2484147,174.63605,255.37691)\"
       style=\"fill:#d6d6d1;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1\" />
  </g>
</svg>")

(defun notmuch-tag-tag-icon ()
  "Return SVG data representing a tag icon.
This can be used with `notmuch-tag-format-image-data'."
  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>
<svg version=\"1.1\" width=\"16\" height=\"16\">
  <g transform=\"translate(0,-1036.3622)\">
    <path
       d=\"m 0.44642857,1040.9336 12.50000043,0 2.700893,3.6161 -2.700893,3.616 -12.50000043,0 z\"
       style=\"fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.25;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1\" />
  </g>
</svg>")

(defvar notmuch-tag--format-cache (make-hash-table :test 'equal)
  "Cache of tag format lookup.  Internal to `notmuch-tag-format-tag'.")

(defun notmuch-tag-clear-cache ()
  "Clear the internal cache of tag formats."
  (clrhash notmuch-tag--format-cache))

(defun notmuch-tag--get-formats (tag format-alist)
  "Find the first item whose car regexp-matches TAG."
  (save-match-data
    ;; Don't use assoc-default since there's no way to distinguish a
    ;; missing key from a present key with a null cdr.
    (cl-assoc tag format-alist
	      :test (lambda (tag key)
		      (and (eq (string-match key tag) 0)
			   (= (match-end 0) (length tag)))))))

(defun notmuch-tag--do-format (tag formatted-tag formats)
  "Apply a tag-formats entry to TAG."
  (cond ((null formats)		;; - Tag not in `formats',
	 formatted-tag