[elpa] externals/ebdb cadffb1 7/7: Rework formatter include/exclude routines

[Eric Abrahamsen]

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

    Rework formatter include/exclude routines
    
    * ebdb.el (ebdb-foo-in-list-p): Rename from ebdb-class-in-list-p, and
      turn into a generic method, with implementations for both classes
      and objects. Handle "shortcuts" like 'mail for 'ebdb-field-mail, and
      'role-not-defunct for ebdb-field-role instances that aren't defunct.
    * ebdb-com.el (ebdb-default-multiline-include,
      ebdb-default-multiline-exclude, ebdb-default-multiline-combine,
      ebdb-default-multiline-collapse): New customization options allowing
      users to set these things without having to message with classes and
      slots. Do not document until we've also figured out the 'sort and
      'header slots. The former should handle these shortcuts, the latter
      should go away altogether.
      (ebdb-default-multiline-formatter): Draw the default
      slot values from the above options.
    * ebdb-format.el (ebdb-formatter): Leave the relevant slot :initforms
      at nil. Defaults should come from the
      `ebdb-default-multiline-formatter' option.
      (ebdb-fmt-process-fields, ebdb-fmt-collect-fields): Adjust for new
      behavior.
---
 ebdb-com.el    | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 ebdb-format.el | 47 +++++++++++++++++-------------------
 ebdb.el        | 75 +++++++++++++++++++++++++++++++++++++++++++++------------
 3 files changed, 156 insertions(+), 42 deletions(-)

diff --git a/ebdb-com.el b/ebdb-com.el
index a91e7bb..9bc7583 100644
--- a/ebdb-com.el
+++ b/ebdb-com.el
@@ -412,9 +412,81 @@ position-marker mark)."
   :documentation
   "Multi-line formatter for *EBDB* buffers.")
 
+(defcustom ebdb-default-multiline-include nil
+  "A list of field types to include in multiline display.
+Valid list values include all field class names (ebdb-field-*),
+as well as the shortcuts 'mail, 'phone, 'address, 'notes, 'tags,
+and 'role, and the special shortcuts 'mail-primary,
+'mail-defunct, 'mail-not-defunct, 'role-defunct, and
+'role-not-defunct.
+
+If this option is set, *only* fields listed here will be
+displayed.  Also see `ebdb-default-multiline-exclude'."
+  :type 'list
+  :group 'ebdb-record-display)
+
+(defcustom ebdb-default-multiline-exclude
+  '(ebdb-field-uuid
+    ebdb-field-timestamp ebdb-field-creation-date
+    mail-defunct role-defunct)
+  "A list of field types to exclude in multiline display.
+Valid list values include all field class names (ebdb-field-*),
+as well as the shortcuts 'mail, 'phone, 'address, 'notes, 'tags,
+and 'role, and the special shortcuts 'mail-primary,
+'mail-defunct, 'mail-not-defunct, 'role-defunct, and
+'role-not-defunct.
+
+If `ebdb-default-multiline-include' is set, this option will be
+ignored."
+  :type 'list
+  :group 'ebdb-record-display)
+
+(defcustom ebdb-default-multiline-include nil
+  "A list of field types to include in multiline display.
+Valid list values include all field class names (ebdb-field-*),
+as well as the shortcuts 'mail, 'phone, 'address, 'notes, 'tags,
+and 'role, and the special shortcuts 'mail-primary,
+'mail-defunct, 'mail-not-defunct, 'role-defunct, and
+'role-not-defunct.
+
+If this option is set, *only* fields listed here will be
+displayed.  Also see `ebdb-default-multiline-exclude'."
+  :type 'list
+  :group 'ebdb-record-display)
+
+(defcustom ebdb-default-multiline-combine
+  '(ebdb-field-mail ebdb-field-phone)
+  "A list of field types to combine in the multiline display.
+\"Combine\" means that instances of this field class will all be
+displayed on one line.
+
+Valid list values include all field class names (ebdb-field-*),
+as well as the shortcuts 'mail, 'phone, 'address, 'notes, 'tags,
+and 'role, and the special shortcuts 'mail-primary,
+'mail-defunct, 'mail-not-defunct, 'role-defunct, and
+'role-not-defunct."
+  :type 'list
+  :group 'ebdb-record-display)
+
+(defcustom ebdb-default-multiline-collapse
+  '(ebdb-field-address)
+  "A list of field types to collapse in the multiline display.
+\"Collapse\" means that only the first line of instances of this
+field class will be displayed.
+
+Valid list values include all field class names (ebdb-field-*),
+as well as the shortcuts 'mail, 'phone, 'address, 'notes, 'tags,
+and 'role, and the special shortcuts 'mail-primary,
+'mail-defunct, 'mail-not-defunct, 'role-defunct, and
+'role-not-defunct."
+  :type 'list
+  :group 'ebdb-record-display)
+
 (defcustom ebdb-default-multiline-formatter
   (make-instance 'ebdb-formatter-ebdb-multiline
-                :object-name "multiline formatter")
+                :object-name "multiline formatter"
+                :include ebdb-default-multiline-include
+                :exclude ebdb-default-multiline-exclude)
   "The default multiline formatter for *EBDB* buffers."
   :type 'ebdb-formatter-ebdb-multiline
   :group 'ebdb-record-display)
@@ -683,7 +755,7 @@ This happens in addition to any pre-defined indentation of 
STRING."
        header-fields body-fields)
     (dolist (f field-plist)
       (push (ebdb-fmt-compose-field fmt f record)
-           (if (ebdb-class-in-list-p (plist-get f :class) header-classes)
+           (if (ebdb-foo-in-list-p (plist-get f :class) header-classes)
                header-fields
              body-fields)))
     (ebdb-fmt-record-header
diff --git a/ebdb-format.el b/ebdb-format.el
index 3dd7257..115bb2d 100644
--- a/ebdb-format.el
+++ b/ebdb-format.el
@@ -44,30 +44,29 @@
     :initform `,buffer-file-coding-system
     :documentation "The coding system for the formatted
     file/buffer/stream.")
-   ;; TODO: Provide for "psuedo field classes" like 'primary-mail and
-   ;; 'role-mail.
+   ;; The elements of the next two slots, besides field class symbols,
+   ;; can also use some shortcut symbols: mail, phone, address, notes,
+   ;; tags, role, mail-primary, mail-defunct, mail-not-defunct,
+   ;; role-defunct, and role-not-defunct.
    (include
     :type list
     :initarg :include
     :initform nil
-    :documentation "A list of field classes to include.  If
-    \"include\" and \"exclude\" conflict, \"exclude\" loses.")
+    :documentation "A list of field classes to include.")
    (exclude
     :type list
     :initarg :exclude
-    :initform '(ebdb-field-uuid ebdb-field-timestamp ebdb-field-creation-date)
-    :documentation "A list of field classes to exclude.")
+    :initform nil
+    :documentation "A list of field classes to exclude.  This
+    slot is only honored if \"include\" is nil.")
    (sort
     :type list
     :initarg :sort
-    :initform '(ebdb-field-mail ebdb-field-phone ebdb-field-address "_" 
ebdb-field-notes)
+    :initform '(ebdb-field-mail
+               ebdb-field-phone ebdb-field-address "_" ebdb-field-notes)
     :documentation "How field instances should be sorted.  Field
     classes should be listed in their proper sort order.  A \"_\"
     placeholder indicates where all other fields should go." )
-   (primary
-    :type boolean
-    :initarg :primary
-    :initform nil)
    (header
     :type list
     :initarg :header
@@ -78,13 +77,13 @@
    (combine
     :type list
     :initarg :combine
-    :initform '(ebdb-field-mail ebdb-field-phone)
+    :initform nil
     :documentation "A list of field classes which should be
     output with all instances grouped together.")
    (collapse
     :type list
     :initarg :collapse
-    :initform '(ebdb-field-address)
+    :initform nil
     :documentation "A list of field classes which should be
     \"collapsed\". What this means is up to the formatter, but it
     generally indicates that most of the field contents will
@@ -256,15 +255,13 @@ FIELD-STRING1 FIELD-STRING2 ..)."
                          ;; be removed at some point.
                          (lambda (elt) (or (eql (car elt) 'name)
                                            (null (cdr elt))))
-                         (ebdb-record-current-fields record nil t)))))
-       f-class)
+                         (ebdb-record-current-fields record nil t))))))
     (with-slots (exclude include) fmt
       (seq-filter
        (lambda (f)
-        (setq f-class (eieio-object-class-name f))
         (if include
-            (ebdb-class-in-list-p f-class include)
-          (null (ebdb-class-in-list-p f-class exclude))))
+            (ebdb-foo-in-list-p f include)
+          (null (ebdb-foo-in-list-p f exclude))))
        fields))))
 
 (cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter)
@@ -304,30 +301,30 @@ FMT.
 
 This method assumes that fields in FIELD-LIST have already been
 grouped by field class."
-  (let (outlist cls f acc)
+  (let (outlist f acc)
     (with-slots (combine collapse) fmt
       (when combine
        (while (setq f (pop field-list))
-         (setq cls (eieio-object-class-name f))
-         (if (null (ebdb-class-in-list-p cls combine))
+         (if (null (ebdb-foo-in-list-p f combine))
              (push f outlist)
            (push f acc)
            (while (and field-list (same-class-p (car field-list)
                                                 (eieio-object-class f)))
              (push (setq f (pop field-list)) acc))
-           (push `(:class ,cls :style compact :inst ,(nreverse acc)) outlist)
+           (push `(:class ,(eieio-object-class-name f)
+                          :style compact :inst ,(nreverse acc))
+                 outlist)
            (setq acc nil)))
        (setq field-list (nreverse outlist)
              outlist nil))
       (dolist (f field-list)
        (if (listp f)
            (push f outlist)
-         (setq cls (eieio-object-class-name f))
-         (push (list :class cls
+         (push (list :class (eieio-object-class-name f)
                      :inst (list f)
                      :style
                      (cond
-                      ((ebdb-class-in-list-p cls collapse) 'collapse)
+                      ((ebdb-foo-in-list-p f collapse) 'collapse)
                       (t 'normal)))
                outlist)))
       outlist)))
diff --git a/ebdb.el b/ebdb.el
index 1b5683e..5a95a51 100644
--- a/ebdb.el
+++ b/ebdb.el
@@ -2758,7 +2758,7 @@ OLD-FIELD's values as defaults.")
     (pcase query
       (`(nil . ,cls)
        (or (rassq cls alist)
-          (rassq (ebdb-class-in-list-p cls (mapcar #'cdr alist))
+          (rassq (ebdb-foo-in-list-p cls (mapcar #'cdr alist))
                  alist)
           (signal 'ebdb-unacceptable-field (list cls))))
       (`(,slot . nil)
@@ -4055,21 +4055,66 @@ process.")
 
 ;;; Utility functions
 
-(defun ebdb-class-in-list-p (class list)
-  "Check if CLASS is a member of LIST.
-Both CLASS and the members of LIST should be class-name symbols.
-CLASS is \"in\" list if the symbol appears directly in the list,
-or if CLASS is a subclass of one of the classes in LIST.  The
-function returns t in the first case, and the parent class symbol
-in the second."
+(cl-defgeneric ebdb-foo-in-list-p (foo list)
+  "Check if FOO (a class type or class instance) is in LIST.")
+
+(cl-defmethod ebdb-foo-in-list-p ((cls (subclass ebdb-field))
+                                 list)
+  "Check if CLS belongs to one of the classes in LIST.
+CLS is \"in\" list if its class name appears directly in the
+list, or if it is a subclass of one of the classes in LIST.
+Return CLS, or nil."
   (catch 'member
-    (progn
-      ;; First, the easy check.
-      (when (memq class list)
-       (throw 'member t))
-      (dolist (c list nil)
-       (when (child-of-class-p class c)
-         (throw 'member c))))))
+    ;; First the easy check.
+    (when (memq cls list)
+      (throw 'member cls))
+    ;; Then the slightly more exhaustive check.
+    (dolist (c list)
+      (when (and (class-p c)
+                (child-of-class-p cls c))
+       (throw 'member cls)))))
+
+(cl-defmethod ebdb-foo-in-list-p ((obj ebdb-field)
+                                 list)
+  "Check if OBJ belongs to one of the classes in LIST.
+OBJ is \"in\" list if its class name appears directly in the
+list, or if it is a subclass of one of the classes in LIST, or if
+one of the symbols in LIST matches it in some other way.  Return
+the class symbol of OBJ, or nil."
+  (let ((cls-symbol (eieio-object-class-name obj)))
+    ;; First, check the class
+    (or (ebdb-foo-in-list-p cls-symbol list)
+       (catch 'member
+         ;; Then the full object check.
+         (when
+             (or (and (memq 'mail list)
+                      (object-of-class-p obj 'ebdb-field-mail))
+                 (and (memq 'role list)
+                      (object-of-class-p obj 'ebdb-field-role))
+                 (and (memq 'phone list)
+                      (object-of-class-p obj 'ebdb-field-phone))
+                 (and (memq 'address list)
+                      (object-of-class-p obj 'ebdb-field-address))
+                 (and (memq 'notes list)
+                      (object-of-class-p obj 'ebdb-field-notes))
+                 (and (memq 'tags list)
+                      (object-of-class-p obj 'ebdb-field-tags))
+                 (and (memq 'mail-primary list)
+                      (object-of-class-p obj 'ebdb-field-mail)
+                      (eq 'primary (slot-value obj 'priority)))
+                 (and (memq 'mail-defunct list)
+                      (object-of-class-p obj 'ebdb-field-mail)
+                      (eq 'defunct (slot-value obj 'priority)))
+                 (and (memq 'mail-not-defunct list)
+                      (object-of-class-p obj 'ebdb-field-mail)
+                      (null (eq 'defunct (slot-value obj 'priority))))
+                 (and (memq 'role-defunct list)
+                      (object-of-class-p obj 'ebdb-field-role)
+                      (slot-value obj 'defunct))
+                 (and (memq 'role-not-defunct list)
+                      (object-of-class-p obj 'ebdb-field-role)
+                      (null (slot-value obj 'defunct))))
+           (throw 'member cls-symbol))))))
 
 (defun ebdb-dirty-dbs (&optional dbs)
   "Return all databases marked \"dirty\"."