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.

diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi
index 5a3957758c9308397a50ff0220b2b7d92b9a0e63..296dc520a1b9ced3a6192c6863a14e8267577f5e 100644 (file)
--- 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 5b868440108fd7f2494e59e65d232997c0b041ad..f2c20b6a8066943c0a014d9861bc973daa48e2bf 100644 (file)
--- 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)))