[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master dfaf150631: Add a new library to format variable-pitch tables
|
From: |
Lars Ingebrigtsen |
|
Subject: |
master dfaf150631: Add a new library to format variable-pitch tables |
|
Date: |
Sat, 19 Feb 2022 07:16:35 -0500 (EST) |
branch: master
commit dfaf150631a235f7239774b73676955244513c54
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>
Add a new library to format variable-pitch tables
* doc/misc/vtable.texi (Index): New manual.
* lisp/emacs-lisp/vtable.el: New library.
---
doc/misc/vtable.texi | 521 +++++++++++++++++++++++++
etc/NEWS | 6 +
lisp/emacs-lisp/vtable.el | 731 +++++++++++++++++++++++++++++++++++
test/lisp/emacs-lisp/vtable-tests.el | 42 ++
4 files changed, 1300 insertions(+)
diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi
new file mode 100644
index 0000000000..5c010a1f79
--- /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-<left>
+Move to the previous column (@code{vtable-previous-column}).
+
+@item M-<right>
+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 706c88d67b..e1dc64c8aa 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 0000000000..9107c4439c
--- /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 <https://www.gnu.org/licenses/>.
+
+;;; 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-<left>" #'vtable-previous-column
+ "M-<right>" #'vtable-next-column)
+
+(defvar-keymap vtable-header-line-map
+ :parent vtable-map
+ "<follow-link>" 'mouse-face
+ "<mouse-2>" #'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
+ "<header-line> <mouse-1>" 'vtable-header-line-sort
+ "<header-line> <mouse-2>" '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 0000000000..627d9f9c5d
--- /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 <https://www.gnu.org/licenses/>.
+
+;;; 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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master dfaf150631: Add a new library to format variable-pitch tables,
Lars Ingebrigtsen <=