From f36ff9da170abeada75d7c3d29ba420ffe7c02f4 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Fri, 15 Apr 2022 11:46:40 +0200
Subject: 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.
---
 lisp/emacs-lisp/vtable.el | 59 ++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 45 insertions(+), 14 deletions(-)

(limited to 'lisp/emacs-lisp')

diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
index 5b868440108..f2c20b6a806 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)))
-- 
cgit v1.2.3