[elpa] externals/ebdb ea2a149 16/33: Add generic tags field

[Eric Abrahamsen]

branch: externals/ebdb
commit ea2a149e96ceea410a4ffbcc9262f39a1f84a5f6
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    Add generic tags field
    
    * ebdb.el (ebdb-field-tags): New class. Previously there was only the
      org-tags field in ebdb-org; now this generic class provides much of
      the same behavior, and the org-specific class is a subclass.
      (ebdb-string, ebdb-init-field): Basic methods, moved over from
      ebdb-org.
      (ebdb-tags): Variable holding tags used in the EBDB, moved over and
      renamed from ebdb-org-tags.
      (ebdb-search-read, ebdb-field-search): Use the Org function
      org-make-tags-matcher to prompt for tag search criteria and match
      that against records. Free code! Also a search method with string
      specializer. The function specializer is broken?
    * ebdb-org.el (ebdb-org-field-tags): This field now inherits from
      ebdb-field-tags.
      (ebdb-org-agenda-popup): Command for popping up an EBDB buffer from
      an Org Agenda tags-match buffer, containing records matching the Org
      tags search.
      (ebdb-read): This is really the only method that makes the
      org-specific class any different.
    * ebdb-com.el (ebdb-search-tags): Provide and bind a specific search
      command for searching on tags, for convenience.
---
 ebdb-com.el | 23 ++++++++++++++++------
 ebdb-org.el | 64 ++++++++++++++++++++++---------------------------------------
 ebdb.el     | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 95 insertions(+), 47 deletions(-)

diff --git a/ebdb-com.el b/ebdb-com.el
index 34b0105..5d10dd3 100644
--- a/ebdb-com.el
+++ b/ebdb-com.el
@@ -310,6 +310,9 @@ display information."
     (define-key km (kbd "/ c")         'ebdb-search-modified)
     (define-key km (kbd "| c")         'ebdb-search-modified)
     (define-key km (kbd "+ c")         'ebdb-search-modified)
+    (define-key km (kbd "/ t")         'ebdb-search-tags)
+    (define-key km (kbd "| t")         'ebdb-search-tags)
+    (define-key km (kbd "+ t")         'ebdb-search-tags)
     (define-key km (kbd "/ C")         'ebdb-search-record-class)
     (define-key km (kbd "/ C")         'ebdb-search-record-class)
     (define-key km (kbd "| C")         'ebdb-search-record-class)
@@ -1911,6 +1914,14 @@ in any field."
   (ebdb-search-display style `((dirty t)) fmt))
 
 ;;;###autoload
+(defun ebdb-search-tags (style tags &optional fmt)
+  "Run a search of record tags."
+  (interactive (list (ebdb-search-style)
+                    (ebdb-search-read 'ebdb-field-tags)
+                    (ebdb-formatter-prefix)))
+  (ebdb-search-display style `((ebdb-field-tags ,tags)) fmt))
+
+;;;###autoload
 (defun ebdb-search-duplicates (&optional fields fmt)
   "Search all records that have duplicate entries for FIELDS.
 The list FIELDS may contain the symbols `name', `mail', and `aka'.
@@ -1937,12 +1948,12 @@ The search results are displayed in the EBDB buffer."
 
       (if (memq 'mail fields)
           (dolist (mail (ebdb-record-mail-canon record))
-              (setq hash (ebdb-gethash mail '(mail)))
-              (when (> (length hash) 1)
-                (setq ret (append hash ret))
-                (message "EBDB record `%s' has duplicate mail `%s'."
-                         (ebdb-record-name record) mail)
-                (sit-for 0))))
+            (setq hash (ebdb-gethash mail '(mail)))
+            (when (> (length hash) 1)
+              (setq ret (append hash ret))
+              (message "EBDB record `%s' has duplicate mail `%s'."
+                       (ebdb-record-name record) mail)
+              (sit-for 0))))
 
       (if (and (memq 'aka fields)
               (slot-exists-p record 'aka))
diff --git a/ebdb-org.el b/ebdb-org.el
index 011157e..4cbfeae 100644
--- a/ebdb-org.el
+++ b/ebdb-org.el
@@ -54,6 +54,7 @@
 
 (require 'ebdb-com)
 (require 'org)
+(require 'org-agenda)
 
 (if (fboundp 'org-link-set-parameters)
     (org-link-set-parameters "ebdb"
@@ -116,58 +117,39 @@ italicized, in all other cases it is left unchanged."
     (format "<text:span text:style-name=\"Emphasis\">%s</text:span>" desc))
    (t desc)))
 
-(defvar ebdb-org-tags nil
-  "Variable holding tags defined for EBDB records.
-
-This list is added to the result of
-`org-global-tags-completion-table' when producing a list of
-potential tags for completion.")
-
-(push '(ebdb-org-field-tags ":" ":") ebdb-separator-alist)
-
 ;;;###autoload
-(defclass ebdb-org-field-tags (ebdb-field-user)
-  ((tags
-    :type (list-of string)
-    :initarg :tags
-    :custom (repeat string)
-    :initform nil))
+(defclass ebdb-org-field-tags (ebdb-field-tags)
+  nil
   :human-readable "org tags")
 
-(cl-defmethod ebdb-string ((field ebdb-org-field-tags))
-  (ebdb-concat 'ebdb-org-field-tags (slot-value field 'tags)))
-
 (cl-defmethod ebdb-read ((field (subclass ebdb-org-field-tags)) &optional 
slots obj)
-  (let* ((crm-separator (cadr (assq 'ebdb-org-field-tags 
ebdb-separator-alist)))
+  (let* ((crm-separator (cadr (assq 'ebdb-field-tags ebdb-separator-alist)))
         (val (completing-read-multiple
               "Tags: "
               (append (org-global-tags-completion-table)
-                      (when ebdb-org-tags
-                        (mapcar #'list ebdb-org-tags)))
+                      (when ebdb-tags
+                        (mapcar #'list ebdb-tags)))
               nil nil
               (when obj (ebdb-string obj)))))
     (cl-call-next-method field (plist-put slots :tags val))))
 
-(cl-defmethod ebdb-search-read ((_class (subclass ebdb-org-field-tags)))
-  (let ((crm-separator (cadr (assq 'ebdb-org-field-tags 
ebdb-separator-alist))))
-    (completing-read-multiple
-     "Search for tags: "
-     (append (org-global-tags-completion-table)
-            (when ebdb-org-tags
-              (mapcar #'list ebdb-org-tags)))
-     nil nil)))
-
-(cl-defmethod ebdb-field-search ((field ebdb-org-field-tags) (tag-list list))
-  (catch 'found
-    (dolist (tag (slot-value field 'tags) nil)
-      (dolist (tt tag-list)
-       (when (string-match-p tt tag)
-        (throw 'found t))))))
-
-(cl-defmethod ebdb-init-field ((field ebdb-org-field-tags) _record)
-  (let ((tags (slot-value field 'tags)))
-    (dolist (tag tags)
-      (add-to-list 'ebdb-org-tags tag))))
+;;;###autoload
+(defun ebdb-org-agenda-popup (&optional inter)
+  "Pop up an *EBDB* buffer from an Org Agenda tags search.
+Uses the tags searched for in the Agenda buffer to do an
+equivalent tags search of EBDB records.
+
+To do this automatically for every search, add this function to
+`org-agenda-mode-hook'."
+  (interactive "p")
+  (if (null (and (derived-mode-p 'org-agenda-mode)
+                (eql org-agenda-type 'tags)))
+      (when inter
+       (message "Not in an Org Agenda tags search buffer"))
+    (let* ((func (cdr (org-make-tags-matcher org-agenda-query-string)))
+          (records (ebdb-search (ebdb-records)
+                                `((ebdb-field-tags ,func)))))
+      (ebdb-display-records records nil nil nil (ebdb-popup-window)))))
 
 (cl-defmethod ebdb-make-buffer-name (&context (major-mode org-mode))
   "Use a separate EBDB buffer for Org-related contacts."
diff --git a/ebdb.el b/ebdb.el
index e26ebd7..96d6d7f 100644
--- a/ebdb.el
+++ b/ebdb.el
@@ -65,6 +65,7 @@
 (autoload 'diary-sexp-entry "diary-lib")
 (autoload 'diary-add-to-list "diary-lib")
 (autoload 'org-agenda-list "org-agenda")
+(autoload 'org-make-tags-matcher "org")
 (defvar ebdb-i18n-countries)
 (defvar calendar-month-name-array)
 
@@ -2180,6 +2181,60 @@ See `ebdb-url-valid-schemes' for a list of acceptable 
schemes."
 (cl-defmethod ebdb-string ((field ebdb-field-gender))
   (symbol-name (slot-value field 'gender)))
 
+;; Tags field.
+
+;; This field class holds a list of tags that apply to the record.
+;; The main advantage is custom searching that lets users search on
+;; multiple tags with inclusion and exclusion.
+
+(defvar ebdb-tags nil
+  "Variable holding tags defined for EBDB records.")
+
+(push '(ebdb-field-tags ":" ":") ebdb-separator-alist)
+
+(defclass ebdb-field-tags (ebdb-field-user ebdb-field-singleton)
+  ((tags
+    :initarg :tags
+    :initform nil
+    :type list
+    :custom (repeat string)
+    :documentation
+    "List of string tags."))
+  :documentation "A field class holding a list of string tags
+   for a record.  Also see `ebdb-org-field-tags', which behaves
+   like this class but also completes on tags defined in Org
+   files."
+  :human-readable "tags")
+
+(cl-defmethod ebdb-string ((field ebdb-field-tags))
+  (ebdb-concat 'ebdb-field-tags (slot-value field 'tags)))
+
+(cl-defmethod ebdb-search-read ((_class (subclass ebdb-field-tags)))
+  (cdr
+   ;; Thank you Org!
+   (org-make-tags-matcher
+    (ebdb-read-string
+     "Search for tags (eg +tag1-tag2|tag3): "))))
+
+(cl-defmethod ebdb-field-search ((field ebdb-field-tags)
+                                func)
+  ;; This guard should be a specializer in the arglist, but the
+  ;; "function" specializer doesn't appear to work.
+  (when (functionp func)
+    ;; The t and 1 are bogus arguments to fool the matcher into thinking
+    ;; we're dealing an Org heading.
+    (funcall func t (slot-value field 'tags) 1)))
+
+(cl-defmethod ebdb-field-search ((field ebdb-field-tags)
+                                (tag string))
+  (seq-find (lambda (tg) (string-match-p tag tg))
+           (slot-value field 'tags)))
+
+(cl-defmethod ebdb-init-field ((field ebdb-field-tags) _record)
+  (let ((tags (slot-value field 'tags)))
+    (dolist (tag tags)
+      (add-to-list 'ebdb-tags tag))))
+
 ;;; Fields that change EBDB's behavior.
 
 ;;; Mail aliases