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:
parent
2b92b57923
commit
f36ff9da17
@ -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
|
||||
|
@ -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)))
|
||||
|
Loading…
Reference in New Issue
Block a user