master f36ff9da17: Allow using faces for colors in vtable

[Lars Ingebrigtsen]

branch: master
commit f36ff9da170abeada75d7c3d29ba420ffe7c02f4
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Allow using faces for colors in vtable
    
    * doc/misc/vtable.texi (Making A Table): Adjust color documentation.
    * lisp/emacs-lisp/vtable.el (make-vtable): Mix more.
    (vtable--compute-colors): Mix both foreground and background colors.
    (vtable--make-color-face, vtable--face-blend): New functions.
    (vtable--insert-line): Adjust usage.
---
 doc/misc/vtable.texi      | 10 ++++----
 lisp/emacs-lisp/vtable.el | 59 ++++++++++++++++++++++++++++++++++++-----------
 2 files changed, 51 insertions(+), 18 deletions(-)

diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi
index 5a3957758c..296dc520a1 100644
--- a/doc/misc/vtable.texi
+++ b/doc/misc/vtable.texi
@@ -392,16 +392,18 @@ If present, this should be a list of color names to be 
used as the
 background color on the rows.  If there are fewer colors here than
 there are rows, the rows will be repeated.  The most common use
 case here is to have alternating background colors on the rows, so
-this would usually be a list of two colors.
+this would usually be a list of two colors.  This can also be a list
+of faces to be used.
 
 @item :column-colors
 If present, this should be a list of color names to be used as the
 background color on the columns.  If there are fewer colors here than
 there are columns, the colors will be repeated.  The most common use
 case here is to have alternating background colors on the columns, so
-this would usually be a list of two colors.  If both
-@code{:row-colors} and @code{:column-colors} is present, the colors
-will be ``blended'' to produce the final colors in the table.
+this would usually be a list of two colors.  This can also be a list
+of faces to be used.  If both @code{:row-colors} and
+@code{:column-colors} is present, the colors will be ``blended'' to
+produce the final colors in the table.
 
 @item :actions
 This uses the same syntax as @code{define-keymap}, but doesn't refer
diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
index 5b86844010..f2c20b6a80 100644
--- a/lisp/emacs-lisp/vtable.el
+++ b/lisp/emacs-lisp/vtable.el
@@ -145,8 +145,8 @@ See info node `(vtable)Top' for vtable documentation."
           :ellipsis ellipsis)))
     ;; Compute missing column data.
     (setf (vtable-columns table) (vtable--compute-columns table))
-    ;; Compute colors if we have to mix them.
-    (when (and row-colors column-colors)
+    ;; Compute the colors.
+    (when (or row-colors column-colors)
       (setf (slot-value table '-cached-colors)
             (vtable--compute-colors row-colors column-colors)))
     ;; Compute the divider.
@@ -175,9 +175,41 @@ See info node `(vtable)Top' for vtable documentation."
     table))
 
 (defun vtable--compute-colors (row-colors column-colors)
-  (cl-loop for row in row-colors
-           collect (cl-loop for column in column-colors
-                            collect (vtable--color-blend row column))))
+  (cond
+   ((null column-colors)
+    (mapcar #'vtable--make-color-face row-colors))
+   ((null row-colors)
+    (mapcar #'vtable--make-color-face column-colors))
+   (t
+    (cl-loop for row in row-colors
+             collect (cl-loop for column in column-colors
+                              collect (vtable--face-blend
+                                       (vtable--make-color-face row)
+                                       (vtable--make-color-face column)))))))
+
+(defun vtable--make-color-face (object)
+  (if (stringp object)
+      (list :background object)
+    object))
+
+(defun vtable--face-blend (face1 face2)
+  (let ((foreground (vtable--face-color face1 face2 #'face-foreground
+                                        :foreground))
+        (background (vtable--face-color face1 face2 #'face-background
+                                        :background)))
+    `(,@(and foreground (list :foreground foreground))
+      ,@(and background (list :background background)))))
+
+(defun vtable--face-color (face1 face2 accessor slot)
+  (let ((col1 (if (facep face1)
+                  (funcall accessor face1)
+                (plist-get face1 slot)))
+        (col2 (if (facep face2)
+                  (funcall accessor face2)
+                (plist-get face2 slot))))
+    (if (and col1 col2)
+        (vtable--color-blend col1 col2)
+      (or col1 col2))))
 
 ;;; FIXME: This is probably not the right way to blend two colors, is
 ;;; it?
@@ -441,10 +473,11 @@ This also updates the displayed table."
   (let ((start (point))
         (columns (vtable-columns table))
         (column-colors
-         (if (vtable-row-colors table)
-             (elt (slot-value table '-cached-colors)
-                  (mod line-number (length (vtable-row-colors table))))
-           (vtable-column-colors table)))
+         (and (vtable-column-colors table)
+              (if (vtable-row-colors table)
+                  (elt (slot-value table '-cached-colors)
+                       (mod line-number (length (vtable-row-colors table))))
+                (slot-value table '-cached-colors))))
         (divider (vtable-divider table))
         (keymap (slot-value table '-cached-keymap)))
     (seq-do-indexed
@@ -517,8 +550,7 @@ This also updates the displayed table."
            (when column-colors
              (add-face-text-property
               start (point)
-              (list :background
-                    (elt column-colors (mod index (length column-colors))))))
+              (elt column-colors (mod index (length column-colors)))))
            (when (and divider (not last))
              (insert divider)
              (setq start (point))))))
@@ -526,11 +558,10 @@ This also updates the displayed table."
     (insert "\n")
     (put-text-property start (point) 'vtable-object (car line))
     (unless column-colors
-      (when-let ((row-colors (vtable-row-colors table)))
+      (when-let ((row-colors (slot-value table '-cached-colors)))
         (add-face-text-property
          start (point)
-         (list :background
-               (elt row-colors (mod line-number (length row-colors)))))))))
+         (elt row-colors (mod line-number (length row-colors))))))))
 
 (defun vtable--cache-key ()
   (cons (frame-terminal) (window-width)))