[elpa] externals/ebdb 4cb0dd2 01/11: Refactor record formatting

[Eric Abrahamsen]

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

    Refactor record formatting
    
    The main change being dropping ebdb-fmt-record-body and
    ebdb-fmt-compose-field in favor of new method ebdb-fmt-compose-fields,
    which returns all fields as a single string.  First step towards
    allowing fields to have their own sub-fields.
    
    * ebdb-com.el (ebdb-indent-string): Remove function, this is now done
      with filling and indenting.
      (ebdb-fmt-record): Now returns strings instead of inserting them.
      Collects fields and calls ebdb-fmt-record-header and
      ebdb-fmt-compose-fields.
    * ebdb-format.el (ebdb-formatter): Give formatters their own
      format-buffer-name slot, so they don't trample each other.
      (ebdb-fmt-compose-fields): New method that turns all fields into a
      single string.
      (ebdb-fmt-compose-field): Delete function.
      (ebdb-fmt-record-body): Delete function, its job is now done by
      `ebdb-fmt-compose-fields'.
      (ebdb-fmt-process-fields): Change return value from a list of plists
      to a list of alists. There are more fun toys for working with
      alists, like the map-* functions and pcase macros.
      (ebdb-format-to-tmp-buffer): Robustify.
---
 ebdb-com.el    | 268 ++++++++++++++++++++++++++++++---------------------------
 ebdb-format.el | 142 +++++++++++++++---------------
 2 files changed, 214 insertions(+), 196 deletions(-)

diff --git a/ebdb-com.el b/ebdb-com.el
index 30c86ac..9e9ed17 100644
--- a/ebdb-com.el
+++ b/ebdb-com.el
@@ -28,6 +28,7 @@
 (require 'ebdb)
 (require 'ebdb-format)
 (require 'mailabbrev)
+(require 'map)
 
 (eval-and-compile
   (autoload 'build-mail-aliases "mailalias")
@@ -534,6 +535,12 @@ choice: that formatter should be selected explicitly."
             dbs)))))
     (propertize char-string 'face 'ebdb-db-char)))
 
+(cl-defmethod ebdb-fmt-field-label :around ((_fmt ebdb-formatter-ebdb)
+                                           _field
+                                           _style
+                                           (_record ebdb-record))
+  (propertize (cl-call-next-method) 'face 'ebdb-label))
+
 (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter-ebdb)
                                    (field ebdb-field-phone)
                                    (_style (eql oneline))
@@ -657,132 +664,141 @@ Print the first line, add an ellipsis, and add a 
tooltip."
                'keymap image-map)))
     "<img>"))
 
-(defsubst ebdb-indent-string (string column)
-  "Indent nonempty lines in STRING to COLUMN (except first line).
-This happens in addition to any pre-defined indentation of STRING."
-  (replace-regexp-in-string "\n\\([^\n]\\)"
-                            (concat "\n" (make-string column ?\s) "\\1")
-                            string))
-
-;;; Record display:
-;;; This inserts formatted (pieces of) records into the EBDB buffer.
-
-(cl-defmethod ebdb-fmt-record-body ((_fmt ebdb-formatter-ebdb-multiline)
-                                   (_record ebdb-record)
-                                   (field-list list))
-  (let* ((indent
-         (if field-list
-             (apply #'max (mapcar (lambda (f)
-                                    (string-width (car f)))
-                                  field-list))
-           0))
-        (label-fmt (format "   %%%ds" indent))
-        (fill-column (window-text-width))
-        (fill-prefix (make-string (+ 5 indent) ?\s))
-        (paragraph-start "[^:]+:[^\n]+$")
-        field-string)
-
-    (dolist (c field-list)
-      (insert (format label-fmt (car c)))
-      (put-text-property (line-beginning-position) (point) 'face 'ebdb-label)
-      (insert (setq field-string
-                   (concat
-                    ": "
-                    ;; If I understood the mechanics of filling better, I
-                    ;; could probably do away with `ebdb-indent-string'
-                    ;; altogether.
-                    (ebdb-indent-string (mapconcat #'identity (cdr c) ", ") (+ 
indent 5)))))
-      ;; If there are newlines in the value string, assume the field
-      ;; knows what's it's doing re filling and formatting.
-      (unless (or (string-match-p "\n" field-string)
-                 (null ebdb-fill-field-values))
-       (fill-paragraph))
-      (insert "\n"))))
-
-(cl-defmethod ebdb-fmt-record-body ((_fmt ebdb-formatter-ebdb-oneline)
-                                   (_record ebdb-record)
-                                   (field-list list))
-  (insert " ")
-  (insert (mapconcat (lambda (elt)
-                      (mapconcat #'identity
-                                 (cdr elt) " "))
-                    field-list ", ")))
-
-(cl-defmethod ebdb-fmt-record-header ((_fmt ebdb-formatter-ebdb)
-                                     (record ebdb-record)
-                                     (field-list list))
-  "Insert header for RECORD."
-  ;; Name
-  (let ((record-class (eieio-object-class-name record))
-       (db-chars (ebdb-record-db-char-string record))
-       step)
-    (when db-chars
-      (insert db-chars " "))
-    (setq step (point))
-    ;; We don't actually ask the name field to format itself, just use
-    ;; the cached canonical name string.  We do add the field to the
-    ;; string as a text property, however.
-    (insert (ebdb-record-name record))
-    (add-text-properties (line-beginning-position) (point)
-                        (list 'ebdb-record record-class))
-    (add-text-properties step (point)
-                        (list
-                         'ebdb-field (slot-value record 'name)
-                         'face (cdr (assoc record-class 
ebdb-name-face-alist)))))
-  ;; Everything else
-  (when field-list
-    (insert " - ")
-    (insert
-     (mapconcat
-      (lambda (f)
-       ;; We need to special-case image field, because it is inserted
-       ;; differently.  Conveniently, this also allows us to always
-       ;; keep the image at the end of the header.
-       (unless (eql (plist-get f :class) 'ebdb-field-image)
-         (mapconcat #'identity (cdr f) " ")))
-      field-list
-      ", "))
-    ;; TODO: Check if image is in field-list, not if it exists!
-    (when (and (slot-boundp record 'image)
-              (slot-value record 'image)
-              (display-images-p))
-      (let ((image (ebdb-field-image-get (slot-value record 'image) record)))
-       (when image
-         (insert " ")
-         (insert-image image))))))
-
-(cl-defmethod ebdb-fmt-record-header :after ((_fmt 
ebdb-formatter-ebdb-multiline)
-                                            (_record ebdb-record)
-                                            _field-list)
-  (insert "\n"))
+;;; Record display
 
 (cl-defmethod ebdb-fmt-record ((fmt ebdb-formatter-ebdb)
                               (record ebdb-record))
-  (let ((field-plist
-        (ebdb-fmt-process-fields
-         fmt record
-         (ebdb-fmt-sort-fields
-          fmt record
-          (ebdb-fmt-collect-fields
-           fmt record))))
-       (header-classes (cdr (assoc (eieio-object-class-name record)
-                                    (slot-value fmt 'header))))
-       header-fields body-fields)
-    (dolist (f field-plist)
-      (push (ebdb-fmt-compose-field fmt f record)
-           (if (ebdb-foo-in-list-p (plist-get f :class) header-classes)
-               header-fields
-             body-fields)))
-    (ebdb-fmt-record-header
-     fmt
-     record
-     header-fields)
-
-    (ebdb-fmt-record-body
-     fmt
-     record
-     body-fields)
-    (insert "\n")))
+  (pcase-let* ((header-classes (cdr (assoc (eieio-object-class-name record)
+                                          (slot-value fmt 'header))))
+              ((map header-fields body-fields)
+               (seq-group-by
+                (lambda (f)
+                  ;; FIXME: Consider doing the header/body split in
+                  ;; `ebdb-fmt-process-fields', we've already got the
+                  ;; formatter there.
+                  (if (ebdb-foo-in-list-p (alist-get 'class f)
+                                          header-classes)
+                      'header-fields
+                    'body-fields))
+                (ebdb-fmt-process-fields
+                 fmt record
+                 (ebdb-fmt-sort-fields
+                  fmt record
+                  (ebdb-fmt-collect-fields
+                   fmt record))))))
+    (concat
+     (ebdb-fmt-record-header fmt record header-fields)
+     (ebdb-fmt-compose-fields fmt record body-fields 1))))
+
+(cl-defmethod ebdb-fmt-record-header ((fmt ebdb-formatter-ebdb)
+                                     (record ebdb-record)
+                                     &optional header-fields)
+  (let ((record-class (eieio-object-class-name record)))
+   (concat
+    (propertize
+     (concat
+      (ebdb-record-db-char-string record)
+      " "
+      (propertize (ebdb-record-name record)
+                 'face (cdr (assoc record-class
+                                   ebdb-name-face-alist))))
+     ;; We don't actually ask the name field to format itself, just use
+     ;; the cached canonical name string.  We do add the field to the
+     ;; string as a text property, however.
+     'ebdb-record record-class
+     'ebdb-field (slot-value record 'name))
+    (when header-fields
+      (concat
+       " - "
+       (mapconcat (pcase-lambda ((map style inst))
+                   (mapconcat (lambda (f)
+                                (ebdb-fmt-field fmt f style record))
+                              inst " "))
+                 header-fields " "))))))
+
+(cl-defmethod ebdb-fmt-compose-fields ((fmt ebdb-formatter-ebdb-multiline)
+                                      (record ebdb-record)
+                                      &optional
+                                      field-alist depth)
+  "Turn FIELD-ALIST into a string.
+The FIELD-ALIST structure is that returned by
+`ebdb-fmt-collect-fields'.  It is an alist with three keys:
+'class, 'style, and 'inst.
+
+This function passes the class and field instances to FMT, which
+formats them appropriately, and concatenates them into a
+string."
+  (when field-alist
+    (let* ((field-pairs
+           (mapcar
+            (pcase-lambda ((map style inst class))
+              ;; Field labels,
+              (cons (ebdb-fmt-field-label
+                     fmt
+                     (if (= 1 (length inst))
+                         (car inst)
+                       class)
+                     style
+                     record)
+                    ;; and fields.
+                    (mapconcat
+                     #'identity
+                     (mapcar (lambda (f)
+                               (ebdb-fmt-field fmt f style record))
+                             inst)
+                     ", ")))
+            field-alist))
+          (max-label-width (apply #'max
+                                  (mapcar
+                                   (lambda (s)
+                                     (string-width (car s)))
+                                   field-pairs)))
+          (label-fmt (format " %%%ds"
+                             max-label-width))
+          (paragraph-start "[ \t]* [[:alpha:] ]+: ")
+          (fill-prefix (make-string (+ 3 max-label-width) ? ))
+          (fill-column (window-body-width)))
+      (with-current-buffer (get-buffer-create "format test")
+       (erase-buffer)
+       (insert "\n")
+       (mapc
+        (pcase-lambda (`(,label . ,fields))
+          (let ((start (point)))
+           (insert
+            (concat
+             (format label-fmt label)
+             ": "
+             fields
+             "\n"))
+           (if (string-match-p "\n" fields)
+               ;; If a field value contains newlines, don't try to
+               ;; fill it, just indent.  I still think there should
+               ;; be a way to achieve this purely using
+               ;; `fill-region', but I'm not going to worry about it
+               ;; for now.
+               (indent-region (save-excursion
+                                (goto-char start)
+                                (forward-line)
+                                (point))
+                              (point))
+             (when ebdb-fill-field-values
+               (fill-region start (point))))))
+        field-pairs)
+       (insert "\n\n")
+       (buffer-string)))))
+
+(cl-defmethod ebdb-fmt-compose-fields ((fmt ebdb-formatter-ebdb-oneline)
+                                      (record ebdb-record)
+                                      &optional field-list _depth)
+  (concat
+   (when field-list
+     (concat
+      " - "
+      (mapconcat (pcase-lambda ((map inst style))
+                  (mapconcat (lambda (f) (ebdb-fmt-field fmt f style record))
+                             inst " "))
+                field-list ", ")))
+   "\n"))
 
 (cl-defgeneric ebdb-make-buffer-name (&context (major-mode t))
   "Return the buffer to be used by EBDB.
@@ -882,7 +898,7 @@ name based on the current major mode."
        (insert (ebdb-fmt-header fmt records))
         (dolist (record ebdb-records)
          (setq start (set-marker (nth 2 record) (point)))
-          (ebdb-fmt-record fmt (car record))
+          (insert (ebdb-fmt-record fmt (car record)))
          (put-text-property start (point) 'ebdb-record-number record-number)
          (cl-incf record-number))
        (insert (ebdb-fmt-footer fmt records))
@@ -931,7 +947,7 @@ only happens when removing records.")
                                     (fmt ebdb-formatter-ebdb)
                                     full-record)
   (let ((marker (nth 2 full-record)))
-    (ebdb-fmt-record fmt record)
+    (insert (ebdb-fmt-record fmt record))
     (setf (nth 1 full-record) fmt)
     (if (eq (nth 3 full-record) 'mark)
        (add-face-text-property
@@ -959,6 +975,7 @@ only happens when removing records.")
   (let ((uuid (ebdb-record-uuid record)))
    (setf (car full-record) uuid)
    (insert uuid)
+   (insert "\n")
    'replaced))
 
 (cl-defmethod ebdb-redisplay-record ((record ebdb-record)
@@ -1016,6 +1033,7 @@ displayed records."
     (dolist (b bufs)
       (with-current-buffer b
        (let ((inhibit-read-only t)
+             (ebdb-fill-column (min (window-width) (default-value 
'fill-column)))
              renumber)
          (dolist (r records)
            (catch 'bail
diff --git a/ebdb-format.el b/ebdb-format.el
index 48348bc..ac1f246 100644
--- a/ebdb-format.el
+++ b/ebdb-format.el
@@ -24,13 +24,37 @@
 ;; for creating the *EBDB* buffer as well as exporting to vcard,
 ;; latex, and html formats.
 
+;; The basic idea is: a formatter object controls which record fields
+;; are selected, and ultimately how they're output as text.  The
+;; formatting routine first inserts the value of `ebdb-fmt-header',
+;; then the value of `ebdb-fmt-record' for each record to be output,
+;; then the value of `ebdb-fmt-footer'.
+
+;; For each record, the method `ebdb-fmt-record' first collects its
+;; fields using `ebdb-fmt-collect-fields', which are then sorted by
+;; `ebdb-fmt-sort-fields', then processed with
+;; `ebdb-fmt-process-fields' (this last means handling field
+;; combination or collapse, etc).  Then it splits header fields from
+;; body fields, and formats the header fields with
+;; `ebdb-fmt-record-header', and the body fields with
+;; `ebdb-fmt-compose-fields'.  It concats those two strings and
+;; returns the result.
+
+;; This file also provides the functions `ebdb-format-all-records' and
+;; `ebdb-format-to-tmp-buffer', the difference being that the former
+;; formats the whole database, and the latter only formats the
+;; currently marked or displayed records.
+
 ;;; Code:
 
 (require 'ebdb)
 (declare-function ebdb-do-records "ebdb-com")
 (declare-function ebdb-display-records "ebdb-com")
-;; qp = quoted-printable, might not end up needing this.
-(require 'qp)
+
+(defcustom ebdb-format-buffer-name "*EBDB Format*"
+  "Default name of buffer in which to display formatted records."
+  :type 'string
+  :group 'ebdb-record-display)
 
 (defvar ebdb-formatter-tracker nil
   "Variable for holding all instantiated formatters.")
@@ -41,6 +65,10 @@
     :type string
     :initform "")
    (tracking-symbol :initform ebdb-formatter-tracker)
+   (format-buffer-name
+    :initarg :format-buffer-name
+    :type string
+    :initform `,ebdb-format-buffer-name)
    (coding-system
     :type symbol
     :initarg :coding-system
@@ -114,17 +142,12 @@
 
 (cl-defgeneric ebdb-fmt-record (fmt record)
   "Handle the insertion of formatted RECORD.
-
-This method collects all the fields to be output for RECORD,
-groups them into header fields and body fields, and then calls
-`ebdb-fmt-record-header' and `ebdb-fmt-record-body' with the two
-lists, respectively.")
+This method collects all the fields for RECORD, splits them into
+header and body fields, and then calls `ebdb-fmt-record-header'
+and `ebdb-fmt-compose-fields'.")
 
 (cl-defgeneric ebdb-fmt-record-header (fmt record fields)
-  "Format a header for RECORD, using the fields in FIELDS.")
-
-(cl-defgeneric ebdb-fmt-record-body (fmt record fields)
-  "Format the body of RECORD, using the fields in FIELDS.")
+  "Format a header for RECORD, using fields in FIELDS.")
 
 (cl-defgeneric ebdb-fmt-collect-fields (fmt record &optional fields)
   "Return a list of RECORD's FIELDS to be formatted.")
@@ -138,21 +161,20 @@ slots.")
 (cl-defgeneric ebdb-fmt-sort-fields (fmt record &optional fields)
   "Sort FIELDS belonging to RECORD according to FMT.")
 
-;; Do we still need this now that formatters and specs are collapsed?
-(cl-defgeneric ebdb-fmt-compose-field (fmt field-cons record)
-  "Convert the lists produced by `ebdb-fmt-process-fields'.
+(cl-defgeneric ebdb-fmt-compose-fields (fmt object &optional field-list depth)
+  "Compose the lists produced by `ebdb-fmt-process-fields'.
 The lists of class instances and formatting information are
-turned into lists holding labels strings and instance strings.")
+turned into indented strings, and the entire block is returned as
+a single string value.  Optional argument DEPTH is used when
+recursively composing subfields of fields.")
 
 (cl-defgeneric ebdb-fmt-field (fmt field style record)
   "Format FIELD value of RECORD.
-
 This method only returns the string value of FIELD itself,
 possibly with text properties attached.")
 
 (cl-defgeneric ebdb-fmt-field-label (fmt field-or-class style record)
   "Format a field label, using formatter FMT.
-
 FIELD-OR-CLASS is a field class or a field instance, and STYLE is
 a symbol indicating a style of some sort, such as 'compact or
 'expanded.")
@@ -165,32 +187,6 @@ a symbol indicating a style of some sort, such as 'compact 
or
 (cl-defmethod ebdb-fmt-footer (_fmt _records)
   "")
 
-(cl-defmethod ebdb-fmt-compose-field ((fmt ebdb-formatter)
-                                     field-plist
-                                     (record ebdb-record))
-  "Turn FIELD-PLIST into a list structure suitable for formatting.
-
-The FIELD-PLIST structure is that returned by
-`ebdb-fmt-collect-fields'.  It is a plist with three
-keys: :class, :style, and :inst.
-
-This function passes the class and field instances to FMT, which
-formats them appropriately, and returns a list of (LABEL
-FIELD-STRING1 FIELD-STRING2 ..)."
-  (let* ((style (plist-get field-plist :style))
-        (inst (plist-get field-plist :inst))
-        (label (ebdb-fmt-field-label fmt
-                                     (if (= 1 (length inst))
-                                         (car inst)
-                                       (plist-get field-plist :class))
-                                     style
-                                     record)))
-    (cons label
-         (mapcar
-          (lambda (f)
-            (ebdb-fmt-field fmt f style record))
-          inst))))
-
 (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter)
                                    (cls (subclass ebdb-field))
                                    _style
@@ -304,7 +300,13 @@ At present that means handling the combine and collapse 
slots of
 FMT.
 
 This method assumes that fields in FIELD-LIST have already been
-grouped by field class."
+grouped by field class.
+
+The return value is a list of alists.  Each alist has three keys:
+'class, holding a class symbol, 'style, holding either the symbol
+`collapse' or the symbol `normal', and 'inst, a list of all the
+instances in this bundle.  The `combine' style works by putting
+multiple instances in a single alist."
   (let (outlist f acc)
     (with-slots (combine collapse) fmt
       (when combine
@@ -315,8 +317,8 @@ grouped by field class."
            (while (and field-list (same-class-p (car field-list)
                                                 (eieio-object-class f)))
              (push (setq f (pop field-list)) acc))
-           (push `(:class ,(eieio-object-class-name f)
-                          :style compact :inst ,(nreverse acc))
+           (push `((class . ,(eieio-object-class-name f))
+                   (style . compact) (inst . ,(nreverse acc)))
                  outlist)
            (setq acc nil)))
        (setq field-list (nreverse outlist)
@@ -324,21 +326,19 @@ grouped by field class."
       (dolist (f field-list)
        (if (listp f)
            (push f outlist)
-         (push (list :class (eieio-object-class-name f)
-                     :inst (list f)
-                     :style
-                     (cond
-                      ((ebdb-foo-in-list-p f collapse) 'collapse)
-                      (t 'normal)))
+         (push (list (cons 'class (eieio-object-class-name f))
+                     (cons 'inst (list f))
+                     (cons 'style
+                           (cond
+                            ((ebdb-foo-in-list-p f collapse) 'collapse)
+                            (t 'normal))))
                outlist)))
       (nreverse outlist))))
 
-;;; Basic export routines
+;; No basic implementation of `ebdb-fmt-compose-fields' is given, as
+;; that is entirely formatter-dependent.
 
-(defcustom ebdb-format-buffer-name "*EBDB Format*"
-  "Default name of buffer in which to display formatted records."
-  :type 'string
-  :group 'ebdb-record-display)
+;;; Basic export routines
 
 (defun ebdb-prompt-for-formatter ()
   (interactive)
@@ -355,25 +355,25 @@ grouped by field class."
   (interactive
    (list (ebdb-prompt-for-formatter)
         (ebdb-do-records)))
-  (let ((buf (get-buffer-create ebdb-format-buffer-name))
+  (let ((buf (generate-new-buffer
+             (slot-value formatter 'format-buffer-name)))
        (fmt-coding (slot-value formatter 'coding-system))
        (ebdb-p (object-of-class-p formatter 'ebdb-formatter-ebdb)))
     ;; If the user has chosen an ebdb formatter, we need to
-    ;; special-case it.  First because the ebdb formatters handle
-    ;; insertion themselves and the other formatters don't, which was
-    ;; arguably a bad choice.  Second because ebdb formatting should
-    ;; behave differently here -- we assume that what the user
-    ;; actually wants is a text-mode buffer containing the text that
-    ;; *would have been* displayed in an *EBDB* buffer, but with all
-    ;; properties removed.
+    ;; special-case it.  We assume that what the user actually wants
+    ;; is a text-mode buffer containing the text that *would have
+    ;; been* displayed in an *EBDB* buffer, but with all properties
+    ;; removed.
     (if ebdb-p
        (save-window-excursion
-         (ebdb-display-records records formatter nil nil nil " *EBDB Fake 
Output*")
-         (let ((str (buffer-substring-no-properties
-                     (point-min) (point-max))))
-           (with-current-buffer buf
-             (erase-buffer)
-             (insert str))))
+         (let ((tmp-buf (get-buffer-create " *EBDB Fake Output*")))
+           (unwind-protect
+               (progn
+                 (ebdb-display-records records formatter nil nil nil tmp-buf)
+                 (with-current-buffer buf
+                   (erase-buffer)
+                   (insert-buffer-substring-no-properties tmp-buf)))
+             (kill-buffer tmp-buf))))
       (with-current-buffer buf
        (erase-buffer)
        (insert (ebdb-fmt-header formatter records))