From: Lars Ingebrigtsen Date: Sat, 19 Feb 2022 12:16:19 +0000 (+0100) Subject: Add a new library to format variable-pitch tables X-Git-Tag: emacs-29.0.90~2234 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=dfaf150631a235f7239774b73676955244513c54;p=emacs.git Add a new library to format variable-pitch tables * doc/misc/vtable.texi (Index): New manual. * lisp/emacs-lisp/vtable.el: New library. --- diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi new file mode 100644 index 00000000000..5c010a1f79c --- /dev/null +++ b/doc/misc/vtable.texi @@ -0,0 +1,521 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename ../../info/vtable.info +@settitle Variable Pitch Tables +@include docstyle.texi +@c %**end of header + +@copying +This file documents the GNU vtable.el package. + +Copyright @copyright{} 2022 Free Software Foundation, Inc. + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,'' +and with the Back-Cover Texts as in (a) below. A copy of the license +is included in the section entitled ``GNU Free Documentation License.'' + +(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and +modify this GNU manual.'' +@end quotation +@end copying + +@dircategory Emacs misc features +@direntry +* vtable: (vtable). Variable Pitch Tables. +@end direntry + +@finalout + +@titlepage +@title Variable Pitch Tables +@subtitle Columnar Display of Data. + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top vtable + +@insertcopying +@end ifnottex + +@menu +* Introduction:: Introduction and examples. +* Concepts:: vtable concepts. +* Making A Table:: The main interface function. +* Commands:: vtable commands. +* Interface Functions:: Interface functions. + +Appendices +* GNU Free Documentation License:: The license for this documentation. + +Indices +* Index:: +@end menu + +@node Introduction +@chapter Introduction + +Most modes that display tabular data in Emacs use +@code{tabulated-list-mode}, but it has some limitations: It assumes +that the text it's displaying is monospaced, which makes it difficult +to mix fonts and images in a single list. The @dfn{vtable} (variable +pitch tables) package tackles this instead. + +@code{tabulated-list-mode} is a major mode, and assumes that it +controls the entire buffer. vtable doesn't assume that---you can have +a vtable in the middle of other data, or have several vtables in the +same buffer. + +Here's just about the simplest vtable that can be created: + +@lisp +(make-vtable + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +By default, vtable uses the @code{variable-pitch} font, and +right-aligns columns that only have numerical data (and left-aligns +the rest). + +You'd normally want to name the columns: + +@lisp +(make-vtable + :columns '("Name" "ID") + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +Clicking on the column names will sort the table based on the data in +each object (and in this example, each object is just a simple list). + +By default, the data is displayed ``as is'', that is, the way +@samp{(format "%s" ...)} would display it, but you can override that. + +@lisp +(make-vtable + :columns '("Name" "ID") + :objects '(("Foo" 1034) + ("Gazonk" 45)) + :formatter (lambda (value column &rest _) + (if (= column 1) + (file-size-human-readable value) + value))) +@end lisp + +In this case, that @samp{1034} will be displayed as @samp{1k}---but +will still sort after @samp{45}, because sorting is done on the actual +data, and not the displayed data. + +Alternatively, instead of having a general formatter for the table, +you can instead put the formatter in the column definition: + +@lisp +(make-vtable + :columns '("Name" + (:name "ID" :formatter file-size-human-readable)) + :objects '(("Foo" 1034) + ("Gazonk" 45))) +@end lisp + +The data doesn't have to be simple lists---you can give any type of +object to vtable, but then you also have to write a function that +returns the data for each column. For instance, here's a very simple +version of @kbd{M-x list-buffers}: + +@lisp +(make-vtable + :columns '("Name" "Size" "File") + :objects (buffer-list) + :actions '("k" kill-buffer + "RET" display-buffer) + :getter (lambda (object column vtable) + (pcase (vtable-column vtable column) + ("Name" (buffer-name object)) + ("Size" (buffer-size object)) + ("File" (or (buffer-file-name object) ""))))) +@end lisp + +@var{objects} in this case is a list of buffers. To get the data to be +displayed, vtable calls the @dfn{getter} function, which is called for +each column of every object, and should return something suitable for +display. + +Also note the @dfn{actions}: These are simple commands that will be +called with the object under point. So hitting @kbd{RET} on a line +will result in @code{display-buffer} being called with a buffer object +as the parameter. (You can also supply a keymap to be used, but then +you have to write commands that call @code{vtable-current-object} to +get at the object.) + +Note that the actions aren't called with the data displayed in the +buffer---they're called with the original objects. + +Finally, here's an example that uses just about all the features: + +@lisp +(make-vtable + :columns `(( :name "Thumb" :width "500px" + :displayer + ,(lambda (value max-width table) + (propertize "*" 'display + (create-image value nil nil + :max-width max-width)))) + (:name "Size" :width 10 + :formatter file-size-human-readable) + (:name "Time" :width 10 :primary ascend :direction 'descend) + "Name") + :objects-function (lambda () + (directory-files "~/pics/redslur/" + t "DSC0000[0-5].JPG")) + :actions '("RET" find-file) + :getter (lambda (object column table) + (pcase (vtable-column table column) + ("Name" (file-name-nondirectory object)) + ("Thumb" object) + ("Size" (file-attribute-size (file-attributes object))) + ("Time" (format-time-string + "%F" (file-attribute-modification-time + (file-attributes object)))))) + :separator-width 5 + :keymap (define-keymap + "q" #'kill-buffer)) +@end lisp + +This vtable implements a simple image browser that displays image +thumbnails (that change sizes dynamically depending on the width of +the column), human-readable file sizes, date and file name. The +separator width is 5 typical characters wide. Hitting @kbd{RET} on a +line will open the image in a new window, and hitting @kbd{q} will +kill a buffer. + +@node Concepts +@chapter Concepts + +A vtable lists data about a number of @dfn{objects}. Each object can +be a list or a vector, but it can also be anything else. + +To get the @dfn{value} for a particular column, the @dfn{getter} +function is called on the object. If no getter function is defined, +the default is to try to index the object as a sequence. In any case, +we end up with a value that is then used for sorting. + +This value is then @dfn{formatted} via a @dfn{formatter} function, +which is called with the @dfn{value} as the argument. The formatter +commonly makes the value more reader friendly. + +Finally, the formatted value is passed to the @dfn{displayer} +function, which is responsible for putting the table face on the +formatted value, and also ensuring that it's not wider than the column +width. The displayer will commonly truncate too-long strings and +scale image sizes. + +All these three transforms, the getter, the formatter and the display +functions, can be defined on a per-column basis, and also on a +per-table basis. (The per-column transform takes precedence over the +per-table transform.) + +User commands that are defined on a table does not work on the +displayed data. Instead they are called with the original object as +the argument. + +@node Making A Table +@chapter Making A Table + +@findex make-table +The interface function for making (and optionally inserting a table +into a buffer) is @code{make-table}. It takes the following keyword +parameters: + +@table @code +@item :objects +This is a list of objects to be displayed. It should either be a list +of strings (which will then be displayed as a single-column table), or +a list where each element is a sequence containing a mixture of +strings, number and other objects that can be displayed ``simply''. + +In the latter case, if @code{:columns} is non-@code{nil} and there's +more elements in the sequence than there is in @code{:columns}, only +the @code{:columns}th first elements are displayed. + +@item :objects-function +It's often convenient to generate the objects dynamically (for +instance, to make reversion work automatically). In that case, this +should be a function (which will be called with no arguments), and +should return a value as accepted as an @code{:objects} list. + +@item :columns +This is a list where each element is either a string (the column +name), a plist of keyword/values (to make a @code{vtable-column} +object), or a full @code{vtable-column} object. A +@code{vtable-column} object has the following slots: + +@table @code +@item name +The name of the column. + +@item width +The width of the column. This is either a number (the width of that +many @samp{x} characters in the table's face), or a string on the form +@samp{Xex}, where @var{x} is a number of @samp{x} characters, or a +string on the form @samp{Xpx} (denoting a number of pixels), or a +string on the form @samp{X%} (a percentage of the window's width). + +@item min-width +This uses the same format as @code{width}, but specifies the minimum +width (and overrides @code{width} is @code{width} is smaller than this. + +@item max-width +This uses the same format as @code{width}, but specifies the maximum +width (and overrides @code{width} is @code{width} is larger than this. +@code{min-width}/@code{max-width} can be useful if @code{width} is +given as a percentage of the window width, and you want to ensure that +the column doesn't grow pointlessly large or unreadably narrow. + +@item primary +Whether this is the primary column---this will be used for initial +sorting. This should be either @code{ascend} or @code{descend} to say +which order the table should be sorted in. + +@item getter +If present, this function will be called to return the column value. + +@defun column-getter object table +It's called with two parameters: The object and the table. +@end defun + +@item formatter +If present, this function will be called to format the value. + +@defun column-formatter value +It's called with one parameter: The column value. +@end defun + +@item displayer +If present, this function will be called to prepare the formatted +value for display. This function should return a string with the +table face applied, and also limit the width of the string to the +display width. + +@defun column-displayer fvalue max-width table +@var{fvalue} is the formatted value; @var{max-width} is the maximum +width (in pixels), and @var{table} is the table. +@end defun + +@item align +Should be either @code{right} or @code{left}. +@end table + +@item :getter +If given, this is a function that should return the values to use in +the table, and will be called once for each element in the table +(unless overridden by a column getter function). + +@defun getter object index table +For a simple object (like a sequence), this function will typically +just return the element corresponding to the column index, but the +function can do any computation it wants. If it's more convenient to +write the function based on column names rather than the column index, +the @code{vtable-column} function can be used to map from index to name. +@end defun + +@item :formatter +If present, this is a function that should format the value, and it +will be called on all values in the table (unless overridden by a +column formatter). + +@defun formatter value index table +This function is called with three parameters: The value (as returned +by the getter); the column index, and the table. It can return any +value. + +This can be used to (for instance) format numbers in a human-readable +form. +@end defun + +@item :displayer +Before displaying an element, it's passed to the displaying function +(if any). + +@defun displayer fvalue index max-width table +This is called with four arguments: The formatted value of the element +(as returned by the formatter function); the column index; the display +width (in pixels); and the table. + +This function should return a string with the table face applied, and +truncated to the display width. + +This can be used to (for instance) change the size of images that are +displayed in the table. +@end defun + +@item :use-header-line +If non-@code{nil} (which is the default), use the Emacs header line +machinery to display the column names. This is the most common use +case, but if there's other text in the buffer before the table, or +there are several tables in the same buffer, then this should be +@code{nil}. + +@item :face +The face to be used. This defaults to @code{variable-pitch}. This +face doesn't override the faces in the data, or supplied by the getter +or formatter functions. + +@item :actions +This uses the same syntax as @code{define-keymap}, but doesn't refer +to commands directly. Instead each key is bound to a command that +picks out the current object, and then calls the function specified +with that as the argument. + +@item :keymap +This is a keymap used on the table. The commands here are called as +usual, and if they're supposed to work on the object displayed on the +current line, they can use the @code{vtable-current-object} function +to determine what that object is. + +@item :separator-width +The blank space between columns. + +@item :sort-by +This should be a list of tuples, and specifies how the table is to be +sorted. Each tuple should consist of an integer (the column index) +and either @code{ascend} or @code{descend}. + +The table is first sorted by the first element in this list, and then +the next, until the end is reached. + +@item :ellipsis +By default, when shortening displayed values, an ellipsis will be +shown. If this is @code{nil}, no ellipsis is shown. (The text to use +as the ellipsis is determined by the @code{truncate-string-ellipsis} +function.) + +@findex vtable-insert +@item :insert +By default, @code{make-vtable} will insert the table at point. If this +is @code{nil}, nothing is inserted, but the vtable object is returned, +and you can insert it later with the @code{vtable-insert} function. +@end table + +@node Commands +@chapter Commands + +@table @kbd +@item S +Sort the table by the current column +(@code{vtable-sort-by-current-column}). Note that the table is sorted +according to the data returned by the getter function, not by how it's +displayed in the buffer. Columns that have only numerical data is +sorted as numbers, the rest are sorted as strings. + +@item @{ +Make the current column narrower +(@code{vtable-narrow-current-column}). + +@item @} +Make the current column wider +(@code{vtable-widen-current-column}). + +@item M- +Move to the previous column (@code{vtable-previous-column}). + +@item M- +Move to the next column (@code{vtable-next-column}). + +@item g +Regenerate the table (@code{vtable-revert-command}). This command +mostly makes sense if the table has a @code{:objects-function} that +can fetch new data. +@end table + +@node Interface Functions +@chapter Interface Functions + +People writing modes based on vtable has to interact with the table in +various ways---for instance, to write commands that updates an object +and then displays the result. + +@defun vtable-current-table +This function returns the table under point. +@end defun + +@defun vtable-current-object +This function returns the object on the current line. (Note that this +is the original object, and not the characters displayed in the +buffer.) +@end defun + +@defun vtable-current-column +This function returns the column index of the column under point. +@end defun + +@defun vtable-goto-table table +Move point to the start of @var{table} and return the position. If +@var{table} can't be found in the current buffer, don't move point and +return @code{nil}. +@end defun + +@defun vtable-goto-object object +Move point to the start of the line where @var{object} is displayed in +the current table and return point. If @var{object} can't be found, +don't move point and return @code{nil}. +@end defun + +@defun vtable-goto-column index +Move point to the start of the @var{index}th column. (The first +column is numbered zero.) +@end defun + +@defun vtable-beginning-of-table +Move to the beginning of the current table. +@end defun + +@defun vtable-end-of-table +Move to the end of the current table. +@end defun + +@defun vtable-remove-object table object +Remove @var{object} from @var{table}. This also updates the displayed +table. +@end defun + +@defun vtable-insert-object table object &optional after-object +Insert @var{object} into @var{table}. If @var{after-object}, insert +the object after this object; otherwise append to @var{table}. This +also updates the displayed table. +@end defun + +@defun vtable-update-object table object old-object +Change @var{old-object} into @var{object} in @var{table}. This also +updates the displayed table. + +This has the same effect as calling @code{vtable-remove-object} and +then @code{vtable-insert-object}, but is more efficient. +@end defun + +@defun vtable-column table index +Return the column name of the @var{index}th column in @var{table}. +@end defun + +@node GNU Free Documentation License +@chapter GNU Free Documentation License +@include doclicense.texi + +@node Index +@unnumbered Index +@printindex cp + +@bye + +@c todo up/down markers diff --git a/etc/NEWS b/etc/NEWS index 706c88d67b8..e1dc64c8aa1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -991,6 +991,12 @@ support for pipelines which will move a lot of data. See section ** Miscellaneous ++++ +*** A new package for formatting tabular data, vtable.el, has been added. +This new package allows formatting data using non-monospaced fonts. +Variable pitch fonts, and text using fonts with different sizes can be +displayed, as well as images. See the '(vtable)Top' manual. + --- *** 'list-bookmarks' now includes a type column. Types are registered via a 'bookmark-handler-type' symbol property on diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el new file mode 100644 index 00000000000..9107c4439c0 --- /dev/null +++ b/lisp/emacs-lisp/vtable.el @@ -0,0 +1,731 @@ +;;; vtable.el --- Displaying data in tables -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'text-property-search) +(require 'mule-util) + +(cl-defstruct vtable-column + "A vtable column." + name + width + min-width + max-width + primary + align + getter + formatter + displayer + -numerical) + +(defclass vtable () + ((columns :initarg :columns :accessor vtable-columns) + (objects :initarg :objects :accessor vtable-objects) + (objects-function :initarg :objects-function + :accessor vtable-objects-function) + (getter :initarg :getter :accessor vtable-getter) + (formatter :initarg :formatter :accessor vtable-formatter) + (displayer :initarg :displayer :accessor vtable-displayer) + (use-header-line :initarg :use-header-line + :accessor vtable-use-header-line) + (face :initarg :face :accessor vtable-face) + (actions :initarg :actions :accessor vtable-actions) + (keymap :initarg :keymap :accessor vtable-keymap) + (separator-width :initarg :separator-width :accessor vtable-separator-width) + (sort-by :initarg :sort-by :accessor vtable-sort-by) + (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) + (-cache :initform (make-hash-table :test #'equal))) + "A object to hold the data for a table.") + +(defvar-keymap vtable-map + :suppress t + "S" #'vtable-sort-by-current-column + "{" #'vtable-narrow-current-column + "}" #'vtable-widen-current-column + "g" #'vtable-revert-command + "M-" #'vtable-previous-column + "M-" #'vtable-next-column) + +(defvar-keymap vtable-header-line-map + :parent vtable-map + "" 'mouse-face + "" #'vtable-header-line-sort) + +(cl-defun make-vtable (&key columns objects objects-function + getter + formatter + displayer + (use-header-line t) + (face 'variable-pitch) + actions keymap + (separator-width 1) + sort-by + (ellipsis t) + (insert t)) + "Create and insert a vtable at point. +The vtable object is returned. If INSERT is nil, the table won't +be inserted." + (when objects-function + (setq objects (funcall objects-function))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setf columns (make-list (length (car objects)) ""))) + (setq columns (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) + ;; We'll be altering the list, so create a copy. + (setq objects (copy-sequence objects)) + (let ((table + (make-instance 'vtable + :columns columns + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :ellipsis ellipsis))) + ;; Compute missing column data. + (setf (vtable-columns table) (vtable--compute-columns table)) + (unless sort-by + (seq-do-indexed (lambda (column index) + (when (vtable-column-primary column) + (push (cons index (vtable-column-primary column)) + (vtable-sort-by table)))) + (vtable-columns table))) + (when insert + (vtable-insert table)) + table)) + +;;; Interface utility functions. + +(defun vtable-current-table () + "Return the table under point." + (get-text-property (point) 'vtable)) + +(defun vtable-current-object () + "Return the object under point." + (get-text-property (point) 'vtable-object)) + +(defun vtable-current-column () + "Return the index of the column under point." + (get-text-property (point) 'vtable-column)) + +(defun vtable-beginning-of-table () + "Go to the start of the current table." + (if (text-property-search-backward 'vtable (vtable-current-table)) + (point) + (goto-char (point-min)))) + +(defun vtable-end-of-table () + "Go to the end of the current table." + (if (text-property-search-forward 'vtable (vtable-current-table)) + (point) + (goto-char (point-max)))) + +(defun vtable-goto-object (object) + "Go to OBJECT in the current table. +Return the position of the object if found, and nil if not." + (let ((start (point))) + (vtable-beginning-of-table) + (save-restriction + (narrow-to-region (point) (vtable-end-of-table)) + (if (text-property-search-forward 'vtable-object object #'eq) + (progn + (forward-line -1) + (point)) + (goto-char start) + nil)))) + +(defun vtable-goto-table (table) + "Go to TABLE in the current buffer. +If TABLE is found, return the position of the start of the table. +If it can't be found, return nil and don't move point." + (let ((start (point))) + (goto-char (point-min)) + (if-let ((match (text-property-search-forward 'vtable table t))) + (goto-char (prop-match-beginning match)) + (goto-char start) + nil))) + +(defun vtable-goto-column (column) + "Go to COLUMN on the current line." + (beginning-of-line) + (if-let ((match (text-property-search-forward 'vtable-column column t))) + (goto-char (prop-match-beginning match)) + (end-of-line))) + +(defun vtable-update-object (table object old-object) + "Replace OLD-OBJECT in TABLE with OBJECT." + (let* ((objects (vtable-objects table)) + (inhibit-read-only t)) + ;; First replace the object in the object storage. + (if (eq old-object (car objects)) + ;; It's at the head, so replace it there. + (setf (vtable-objects table) + (cons object (cdr objects))) + ;; Otherwise splice into the list. + (while (and (cdr objects) + (not (eq (cadr objects) old-object))) + (setq objects (cdr objects))) + (unless objects + (error "Can't find the old object")) + (setcar (cdr objects) object)) + ;; Then update the cache... + (let ((line (assq old-object (car (vtable--cache table))))) + (unless line + (error "Can't find cached object")) + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-remove-object (table object) + "Remove OBJECT from TABLE. +This will also remove the displayed line." + ;; First remove from the objects. + (setf (vtable-objects table) (delq object (vtable-objects table))) + ;; Then adjust the cache and display. + (let ((cache (vtable--cache table)) + (inhibit-read-only t)) + (setcar cache (delq (assq object (car cache)) (car cache))) + (save-excursion + (vtable-goto-table table) + (when (vtable-goto-object object) + (delete-line))))) + +(defun vtable-insert-object (table object &optional after-object) + "Insert OBJECT into TABLE after AFTER-OBJECT. +If AFTER-OBJECT is nil (or doesn't exist in the table), insert +OBJECT at the end. +This also updates the displayed table." + ;; First insert into the objects. + (let (pos) + (if (and after-object + (setq pos (memq after-object (vtable-objects table)))) + ;; Splice into list. + (setcdr pos (cons object (cdr pos))) + ;; Append. + (nconc (vtable-objects table) (list object)))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (elem (and after-object + (assq after-object (car cache)))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (not elem) + ;; Append. + (progn + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table)) + ;; Splice into list. + (let ((pos (memq elem (car cache)))) + (setcdr pos (cons line (cdr pos))) + (unless (vtable-goto-object after-object) + (vtable-end-of-table)))) + (let ((start (point))) + (vtable--insert-line table line (nth 1 cache) (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-column (table index) + "Return the name of the INDEXth column in TABLE." + (vtable-column-name (elt (vtable-columns table) index))) + +;;; Generating the table. + +(defun vtable--get-value (object index column table) + "Compute a cell value." + (cond + ((vtable-column-getter column) + (funcall (vtable-column-getter column) + object table)) + ((vtable-getter table) + (funcall (vtable-getter table) + object index table)) + ;; No getter functions; standard getters. + ((stringp object) + object) + (t + (elt object index)))) + +(defun vtable--compute-columns (table) + (let ((numerical (make-vector (length (vtable-columns table)) t)) + (columns (vtable-columns table))) + ;; First determine whether there are any all-numerical columns. + (dolist (object (vtable-objects table)) + (seq-do-indexed + (lambda (_elem index) + (unless (numberp (vtable--get-value object index (elt columns index) + table)) + (setf (elt numerical index) nil))) + (vtable-columns table))) + ;; Then fill in defaults. + (seq-map-indexed + (lambda (column index) + ;; This is used when displaying. + (unless (vtable-column-align column) + (setf (vtable-column-align column) + (if (elt numerical index) + 'right + 'left))) + ;; This is used for sorting. + (setf (vtable-column--numerical column) + (elt numerical index)) + column) + (vtable-columns table)))) + +(defun vtable--spacer (table) + (vtable--compute-width table (vtable-separator-width table))) + +(defun vtable-insert (table) + (let* ((spacer (vtable--spacer table)) + (start (point)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + data widths) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (if-let ((cache (vtable--cache table))) + (setq data (nth 0 cache) + widths (nth 1 cache)) + (setq data (vtable--compute-cache table) + widths (vtable--compute-widths table data)) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths))) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point))) + (vtable--sort table) + ;; Insert the data. + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line widths spacer + ellipsis ellipsis-width)) + (add-text-properties start (point) + (list 'keymap (vtable--make-keymap table) + 'rear-nonsticky t + 'vtable table)) + (goto-char start))) + +(defun vtable--insert-line (table line widths spacer + &optional ellipsis ellipsis-width) + (let ((start (point)) + (columns (vtable-columns table))) + (seq-do-indexed + (lambda (elem index) + (let ((value (nth 0 elem)) + (column (elt columns index)) + (pre-computed (nth 2 elem))) + ;; See if we have any formatters here. + (cond + ((vtable-column-formatter column) + (setq value (funcall (vtable-column-formatter column) value) + pre-computed nil)) + ((vtable-formatter table) + (setq value (funcall (vtable-formatter table) + value index table) + pre-computed nil))) + (let ((displayed + ;; Allow any displayers to have their say. + (cond + ((vtable-column-displayer column) + (funcall (vtable-column-displayer column) + value (elt widths index) table)) + ((vtable-displayer table) + (funcall (vtable-displayer table) + value index (elt widths index) table)) + (pre-computed + ;; If we don't have a displayer, use the pre-made + ;; (cached) string value. + (if (> (nth 1 elem) (elt widths index)) + (concat + (vtable--limit-string + pre-computed (- (elt widths index) ellipsis-width)) + ellipsis) + pre-computed)) + ;; Recompute widths. + (t + (if (> (string-pixel-width value) (elt widths index)) + (concat + (vtable--limit-string + value (- (elt widths index) ellipsis-width)) + ellipsis) + value)))) + (start (point))) + (if (eq (vtable-column-align column) 'left) + (insert displayed + (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + ;; Align to the right. + (insert (propertize " " 'display + (list 'space + :width (list (- (elt widths index) + (string-pixel-width + displayed))))) + displayed + (propertize " " 'display + (list 'space + :width (list spacer))))) + (put-text-property start (point) 'vtable-column index)))) + (cdr line)) + (insert "\n") + (put-text-property start (point) 'vtable-object (car line)))) + +(defun vtable--cache-key () + (cons (frame-terminal) (window-width))) + +(defun vtable--cache (table) + (gethash (vtable--cache-key) (slot-value table '-cache))) + +(defun vtable--clear-cache (table) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) nil)) + +(defun vtable--sort (table) + (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) + (let ((cache (vtable--cache table)) + (numerical (vtable-column--numerical + (elt (vtable-columns table) index)))) + (setcar cache + (sort (car cache) + (lambda (e1 e2) + (let ((c1 (elt e1 (1+ index))) + (c2 (elt e2 (1+ index)))) + (if numerical + (< (car c1) (car c2)) + (string< (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2))))))))) + (when (eq direction 'descend) + (setcar cache (nreverse (car cache))))))) + +(defun vtable--insert-header-line (table widths spacer) + ;; Insert the header directly into the buffer. + (let ((start (point))) + (seq-do-indexed + (lambda (column index) + (let ((name (propertize + (vtable-column-name column) + 'face (list 'header-line (vtable-face table)))) + (start (point)) + displayed) + (insert + (setq displayed + (if (> (string-pixel-width name) (elt widths index)) + (vtable--limit-string name (elt widths index)) + name)) + (propertize " " 'display + (list 'space :width + (list (+ (- (elt widths index) + (string-pixel-width displayed)) + spacer))))) + (put-text-property start (point) 'vtable-column index))) + (vtable-columns table)) + (insert "\n") + (add-face-text-property start (point) 'header-line))) + +(defun vtable--recompute-numerical (table line) + "Recompute numericalness of columns if necessary." + (let ((columns (vtable-columns table)) + (recompute nil)) + (seq-do-indexed + (lambda (elem index) + (when (and (vtable-column--numerical (elt columns index)) + (not (numberp elem))) + (setq recompute t))) + line) + (when recompute + (vtable--compute-columns table)))) + +(defun vtable--set-header-line (table widths spacer) + (setq header-line-format + (string-replace + "%" "%%" + (with-temp-buffer + (insert " ") + (vtable--insert-header-line table widths spacer) + ;; Align the header with the (possibly) fringed buffer text. + (put-text-property + (point-min) (1+ (point-min)) + 'display '(space :align-to 0)) + (buffer-substring (point-min) (1- (point-max)))))) + (vtable-header-mode 1)) + +(defun vtable--limit-string (string pixels) + (while (and (length> string 0) + (> (string-pixel-width string) pixels)) + (setq string (substring string 0 (1- (length string))))) + string) + +(defun vtable--char-width (table) + (string-pixel-width (propertize "x" 'face (vtable-face table)))) + +(defun vtable--compute-width (table spec) + (cond + ((numberp spec) + (* spec (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)ex" spec) + (* (string-to-number (match-string 1 spec)) (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)px" spec) + (string-to-number (match-string 1 spec))) + ((string-match "\\([0-9.]+\\)%" spec) + (* (string-to-number (match-string 1 spec)) (window-width nil t))) + (t + (error "Invalid spec: %s" spec)))) + +(defun vtable--compute-widths (table cache) + "Compute the display widths for TABLE." + (seq-into + (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; Compute based on the displayed widths of + ;; the data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)) + 'vector)) + +(defun vtable--compute-cache (table) + (seq-map + (lambda (object) + (cons object (vtable--compute-cached-line table object))) + (vtable-objects table))) + +(defun vtable--compute-cached-line (table object) + (seq-map-indexed + (lambda (column index) + (let* ((value (vtable--get-value object index column table)) + (string (if (stringp value) + (copy-sequence value) + (format "%s" value)))) + (add-face-text-property 0 (length string) + (vtable-face table) + t string) + ;; We stash the computed width and string here -- if there are + ;; no formatters/displayers, we'll be using the string, and + ;; then won't have to recreate it. + (list value (string-pixel-width string) string))) + (vtable-columns table))) + +(defun vtable--make-keymap (table) + (let ((map (if (or (vtable-actions table) + (vtable-keymap table)) + (copy-keymap vtable-map) + vtable-map))) + (when-let ((actions (vtable-actions table))) + (while actions + (funcall (lambda (key binding) + (keymap-set map key + (lambda (object) + (interactive (list (vtable-current-object))) + (funcall binding object)))) + (car actions) (cadr actions)) + (setq actions (cddr actions)))) + (if (vtable-keymap table) + (progn + (set-keymap-parent (vtable-keymap table) map) + (vtable-keymap table)) + map))) + +(defun vtable-revert () + "Regenerate the table under point." + (let ((table (vtable-current-table)) + (object (vtable-current-object)) + (column (vtable-current-column)) + (inhibit-read-only t)) + (unless table + (user-error "No table under point")) + (delete-region (vtable-beginning-of-table) (vtable-end-of-table)) + (vtable-insert table) + (when object + (vtable-goto-object object)) + (when column + (vtable-goto-column column)))) + +(defun vtable--widths (table) + (nth 1 (vtable--cache table))) + +;;; Commands. + +(defvar-keymap vtable-header-mode-map + " " 'vtable-header-line-sort + " " 'vtable-header-line-sort) + +(define-minor-mode vtable-header-mode + "Minor mode for buffers with vtables with headers." + :keymap vtable-header-mode-map) + +(defun vtable-narrow-current-column () + "Narrow the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (vtable--widths table))) + (setf (aref widths column) + (max (* (vtable--char-width table) 2) + (- (aref widths column) (vtable--char-width table)))) + (vtable-revert))) + +(defun vtable-widen-current-column () + "Widen the current column." + (interactive) + (let* ((table (vtable-current-table)) + (column (vtable-current-column)) + (widths (nth 1 (vtable--cache table)))) + (cl-incf (aref widths column) (vtable--char-width table)) + (vtable-revert))) + +(defun vtable-previous-column () + "Go to the previous column." + (interactive) + (vtable-goto-column + (max 0 (1- (or (vtable-current-column) + (length (vtable--widths (vtable-current-table)))))))) + +(defun vtable-next-column () + "Go to the next column." + (interactive) + (when (vtable-current-column) + (vtable-goto-column + (min (1- (length (vtable--widths (vtable-current-table)))) + (1+ (vtable-current-column)))))) + +(defun vtable-revert-command () + "Re-query data and regenerate the table under point." + (interactive) + (let ((table (vtable-current-table))) + (when (vtable-objects-function table) + (setf (vtable-objects table) (funcall (vtable-objects-function table)))) + (vtable--clear-cache table)) + (vtable-revert)) + +(defun vtable-sort-by-current-column () + "Sort the table under point by the column under point." + (interactive) + (unless (vtable-current-column) + (user-error "No current column")) + (let* ((table (vtable-current-table)) + (last (car (last (vtable-sort-by table)))) + (index (vtable-current-column))) + ;; First prune any previous appearance of this column. + (setf (vtable-sort-by table) + (delq (assq index (vtable-sort-by table)) + (vtable-sort-by table))) + ;; Then insert this as the last sort key. + (setf (vtable-sort-by table) + (append (vtable-sort-by table) + (list (cons index + (if (eq (car last) index) + (if (eq (cdr last) 'ascend) + 'descend + 'ascend) + 'ascend)))))) + (vtable-revert)) + +(defun vtable-header-line-sort (e) + "Sort a vtable from the header line." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos))) + (with-current-buffer (window-buffer (posn-window pos)) + (goto-char (point-min)) + (vtable-goto-column + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'vtable-column + (car obj))) + (vtable-sort-by-current-column)))) + +(provide 'vtable) + +;;; vtable.el ends here diff --git a/test/lisp/emacs-lisp/vtable-tests.el b/test/lisp/emacs-lisp/vtable-tests.el new file mode 100644 index 00000000000..627d9f9c5df --- /dev/null +++ b/test/lisp/emacs-lisp/vtable-tests.el @@ -0,0 +1,42 @@ +;;; vtable-tests.el --- Tests for vtable.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'vtable) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-vstable-compute-columns () + (should + (equal (mapcar + (lambda (column) + (vtable-column-align column)) + (vtable--compute-columns + (make-vtable :columns '("a" "b" "c") + :objects '(("foo" 1 2) + ("bar" 3 :zot)) + :insert nil))) + '(left right left)))) + +;;; vtable-tests.el ends here