1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-15 09:47:20 +00:00

tabulated-list: extend truncation into next align-right column

See discussion on:
https://lists.gnu.org/archive/html/emacs-devel/2016-10/msg01101.html
* lisp/emacs-lisp/tabulated-list.el
(tabulated-list--near-rows): New variable.
(tabulated-list-print, tabulated-list-set-col): Use it.
(tabulated-list--col-local-max-widths): New defsubst.
(tabulated-list-print-col): Use it.  If the next column is
align-right, and has some space left then don't truncate to width,
use some of the available space from the next column.
This commit is contained in:
Tino Calancha 2016-11-14 17:31:44 +09:00
parent 0bf888422d
commit db43613307

View File

@ -102,6 +102,8 @@ It is called with two arguments, ID and COLS. ID is a Lisp
object identifying the entry, and COLS is a vector of column object identifying the entry, and COLS is a vector of column
descriptors, as documented in `tabulated-list-entries'.") descriptors, as documented in `tabulated-list-entries'.")
(defvar tabulated-list--near-rows)
(defvar-local tabulated-list-sort-key nil (defvar-local tabulated-list-sort-key nil
"Sort key for the current Tabulated List mode buffer. "Sort key for the current Tabulated List mode buffer.
If nil, no additional sorting is performed. If nil, no additional sorting is performed.
@ -298,6 +300,14 @@ column. Negate the predicate that would be returned if
(lambda (a b) (not (funcall sorter a b))) (lambda (a b) (not (funcall sorter a b)))
sorter)))) sorter))))
(defsubst tabulated-list--col-local-max-widths (col)
"Return maximum entry widths at column COL around current row.
Check the current row, the previous one and the next row."
(apply #'max (mapcar (lambda (x)
(let ((nt (elt x col)))
(string-width (if (stringp nt) nt (car nt)))))
tabulated-list--near-rows)))
(defun tabulated-list-print (&optional remember-pos update) (defun tabulated-list-print (&optional remember-pos update)
"Populate the current Tabulated List mode buffer. "Populate the current Tabulated List mode buffer.
This sorts the `tabulated-list-entries' list if sorting is This sorts the `tabulated-list-entries' list if sorting is
@ -340,8 +350,14 @@ changing `tabulated-list-sort-key'."
(unless tabulated-list-use-header-line (unless tabulated-list-use-header-line
(tabulated-list-print-fake-header))) (tabulated-list-print-fake-header)))
;; Finally, print the resulting list. ;; Finally, print the resulting list.
(dolist (elt entries) (while entries
(let ((id (car elt))) (let* ((elt (car entries))
(tabulated-list--near-rows
(list
(or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt))
(cadr elt)
(or (cadr (cadr entries)) (cadr elt))))
(id (car elt)))
(and entry-id (and entry-id
(equal entry-id id) (equal entry-id id)
(setq entry-id nil (setq entry-id nil
@ -368,7 +384,8 @@ changing `tabulated-list-sort-key'."
(t t))) (t t)))
(let ((old (point))) (let ((old (point)))
(forward-line 1) (forward-line 1)
(delete-region old (point))))))) (delete-region old (point))))))
(setq entries (cdr entries)))
(set-buffer-modified-p nil) (set-buffer-modified-p nil)
;; If REMEMBER-POS was specified, move to the "old" location. ;; If REMEMBER-POS was specified, move to the "old" location.
(if saved-pt (if saved-pt
@ -402,8 +419,6 @@ of column descriptors."
N is the column number, COL-DESC is a column descriptor (see N is the column number, COL-DESC is a column descriptor (see
`tabulated-list-entries'), and X is the column number at point. `tabulated-list-entries'), and X is the column number at point.
Return the column number after insertion." Return the column number after insertion."
;; TODO: don't truncate to `width' if the next column is align-right
;; and has some space left.
(let* ((format (aref tabulated-list-format n)) (let* ((format (aref tabulated-list-format n))
(name (nth 0 format)) (name (nth 0 format))
(width (nth 1 format)) (width (nth 1 format))
@ -414,12 +429,29 @@ Return the column number after insertion."
(label-width (string-width label)) (label-width (string-width label))
(help-echo (concat (car format) ": " label)) (help-echo (concat (car format) ": " label))
(opoint (point)) (opoint (point))
(not-last-col (< (1+ n) (length tabulated-list-format)))) (not-last-col (< (1+ n) (length tabulated-list-format)))
available-space)
(when not-last-col
(let* ((next-col-format (aref tabulated-list-format (1+ n)))
(next-col-right-align (plist-get (nthcdr 3 next-col-format)
:right-align))
(next-col-width (nth 1 next-col-format)))
(setq available-space
(if (and (not right-align)
next-col-right-align)
(-
(+ width next-col-width)
(min next-col-width
(tabulated-list--col-local-max-widths (1+ n))))
width))))
;; Truncate labels if necessary (except last column). ;; Truncate labels if necessary (except last column).
(and not-last-col ;; Don't truncate to `width' if the next column is align-right
(> label-width width) ;; and has some space left, truncate to `available-space' instead.
(setq label (truncate-string-to-width label width nil nil t) (when (and not-last-col
label-width width)) (> label-width available-space)
(setq label (truncate-string-to-width
label available-space nil nil t)
label-width available-space)))
(setq label (bidi-string-mark-left-to-right label)) (setq label (bidi-string-mark-left-to-right label))
(when (and right-align (> width label-width)) (when (and right-align (> width label-width))
(let ((shift (- width label-width))) (let ((shift (- width label-width)))
@ -437,7 +469,7 @@ Return the column number after insertion."
(when not-last-col (when not-last-col
(when (> pad-right 0) (insert (make-string pad-right ?\s))) (when (> pad-right 0) (insert (make-string pad-right ?\s)))
(insert (propertize (insert (propertize
(make-string (- next-x x label-width pad-right) ?\s) (make-string (- width (min width label-width)) ?\s)
'display `(space :align-to ,next-x)))) 'display `(space :align-to ,next-x))))
(put-text-property opoint (point) 'tabulated-list-column-name name) (put-text-property opoint (point) 'tabulated-list-column-name name)
next-x))) next-x)))
@ -494,7 +526,12 @@ this is the vector stored within it."
(when (< pos eol) (when (< pos eol)
(delete-region pos (next-single-property-change pos prop nil eol)) (delete-region pos (next-single-property-change pos prop nil eol))
(goto-char pos) (goto-char pos)
(tabulated-list-print-col col desc (current-column)) (let ((tabulated-list--near-rows
(list
(tabulated-list-get-entry (point-at-bol 0))
entry
(or (tabulated-list-get-entry (point-at-bol 2)) entry))))
(tabulated-list-print-col col desc (current-column)))
(if change-entry-data (if change-entry-data
(aset entry col desc)) (aset entry col desc))
(put-text-property pos (point) 'tabulated-list-id id) (put-text-property pos (point) 'tabulated-list-id id)