1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-01 08:17:38 +00:00

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.
This commit is contained in:
Lars Ingebrigtsen 2022-04-15 11:46:40 +02:00
parent 2b92b57923
commit f36ff9da17
2 changed files with 51 additions and 18 deletions

View File

@ -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

View File

@ -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)))