branch: externals/ebdb
commit b240223aba0f7e92e355178026a03c7ce24956ae
Author: Eric Abrahamsen <e...@ericabrahamsen.net>
Commit: Eric Abrahamsen <e...@ericabrahamsen.net>
Rework field sorting
* ebdb.el (ebdb-field-compare): New method for comparing/sorting
fields. By default, don't change order.
(ebdb-field-compare): Remove old (unused) function
`ebdb-sort-mails', and replace with new method for mail fields.
* ebdb-format.el (ebdb-fmt-sort-fields): Instead of fretting about how
to correctly sort mails when editing the database, just do the
sorting at display time. Fields are now sorted first using
`ebdb-field-compare', then the formatter sort order. Use seq.el
sorting functions, instead of my homemade bird's nest.
(ebdb-fmt-process-fields): Make sure combined field instances
maintain sort order.
---
ebdb-format.el | 46 ++++++++++++++++++++--------------------------
ebdb.el | 27 ++++++++++++++++-----------
2 files changed, 36 insertions(+), 37 deletions(-)
diff --git a/ebdb-format.el b/ebdb-format.el
index 65e4dbd..3dd7257 100644
--- a/ebdb-format.el
+++ b/ebdb-format.el
@@ -277,35 +277,28 @@ FIELD-STRING1 FIELD-STRING2 ..)."
(cl-defmethod ebdb-fmt-sort-fields ((fmt ebdb-formatter)
(_record ebdb-record)
field-list)
- (let ((sort (slot-value fmt 'sort))
- f acc outlist class)
- (when sort
- (dolist (s sort)
- (if (symbolp s)
- (progn
- (setq class (cl--find-class s))
- (while (setq f (pop field-list))
- (if (same-class-p f class)
- (push f outlist)
- (push f acc)))
- (setq field-list acc
- acc nil))
- ;; We assume this is the "_" value. Actually, anything
- ;; would do as a catchall placeholder.
- (dolist (fld field-list)
- (setq class (eieio-object-class-name fld))
- (unless (memq class sort)
- ;; This isn't enough -- field still need to be grouped
- ;; by field class.
- (push fld outlist)))))
- (setq field-list (nreverse outlist)))
- field-list))
+ "Sort FIELD-LIST using sort order from FMT.
+First sorts all fields with `ebdb-field-compare', then sorts
+again by the order of each field's class symbol in the 'sort
+slot of FMT."
+ (let* ((sort-order (slot-value fmt 'sort))
+ (catchall (or (seq-position sort-order "_")
+ (length sort-order)))
+ (sorted (seq-sort #'ebdb-field-compare field-list)))
+
+ (when sort-order
+ (setq sorted
+ (seq-sort-by
+ (lambda (f)
+ (or (seq-position sort-order (eieio-object-class-name f))
+ catchall))
+ #'< sorted)))
+ sorted))
(cl-defmethod ebdb-fmt-process-fields ((fmt ebdb-formatter)
(_record ebdb-record)
field-list)
"Process FIELD-LIST for FMT.
-
At present that means handling the combine and collapse slots of
FMT.
@@ -319,9 +312,10 @@ grouped by field class."
(if (null (ebdb-class-in-list-p cls combine))
(push f outlist)
(push f acc)
- (while (and field-list (same-class-p (car field-list)
(eieio-object-class f)))
+ (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 ,acc) outlist)
+ (push `(:class ,cls :style compact :inst ,(nreverse acc)) outlist)
(setq acc nil)))
(setq field-list (nreverse outlist)
outlist nil))
diff --git a/ebdb.el b/ebdb.el
index 03f9a37..1b5683e 100644
--- a/ebdb.el
+++ b/ebdb.el
@@ -958,6 +958,13 @@ chance to react somehow. TYPE is one of the symbols
'sender or
in."
nil)
+(cl-defgeneric ebdb-field-compare (field1 field2)
+ "Return non-nil if FIELD1 should be sorted before FIELD2.")
+
+(cl-defmethod ebdb-field-compare (_field1 _field2)
+ "By default, leave order unchanged."
+ nil)
+
;;; The UUID field.
;; This was originally just a string-value slot, but it was such a
@@ -1515,18 +1522,16 @@ first one."
(setq slots (plist-put slots :aka name)))
(cl-call-next-method class str slots)))
-(defun ebdb-sort-mails (mails)
- "Sort MAILS by their priority slot.
+(cl-defmethod ebdb-field-compare ((m-left ebdb-field-mail)
+ (m-right ebdb-field-mail))
+ "Sort M-LEFT and M-RIGHT by their priority slot.
Primary sorts before normal sorts before defunct."
- (sort
- mails
- (lambda (l r)
- (let ((l-p (slot-value l 'priority))
- (r-p (slot-value r 'priority)))
- (or (and (eq l-p 'primary)
- (memq r-p '(normal defunct)))
- (and (eq l-p 'normal)
- (eq r-p 'defunct)))))))
+ (let ((l-p (slot-value m-left 'priority))
+ (r-p (slot-value m-right 'priority)))
+ (or (and (memq r-p '(normal defunct))
+ (eq l-p 'primary))
+ (and (eq r-p 'defunct)
+ (eq l-p 'normal)))))
(cl-defmethod cl-print-object ((mail ebdb-field-mail) stream)
(princ (format "#<%S %s>"
