* term.c (tty_send_additional_strings): No need to fflush here,
[emacs.git] / lisp / emacs-lisp / tabulated-list.el
1 ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
4
5 ;; Author: Chong Yidong <cyd@stupidchicken.com>
6 ;; Keywords: extensions, lisp
7 ;; Version: 1.0
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; This file defines Tabulated List mode, a generic major mode for
27 ;; displaying lists of tabulated data, intended for other major modes
28 ;; to inherit from.  It provides several utility routines, e.g. for
29 ;; pretty-printing lines of tabulated data to fit into the appropriate
30 ;; columns.
31
32 ;; For usage information, see the documentation of `tabulated-list-mode'.
33
34 ;; This package originated from Tom Tromey's Package Menu mode,
35 ;; extended and generalized to be used by other modes.
36
37 ;;; Code:
38
39 ;; The reason `tabulated-list-format' and other variables are
40 ;; permanent-local is to make it convenient to switch to a different
41 ;; major mode, switch back, and have the original Tabulated List data
42 ;; still valid.  See, for example, ebuff-menu.el.
43
44 (defvar-local tabulated-list-format nil
45   "The format of the current Tabulated List mode buffer.
46 This should be a vector of elements (NAME WIDTH SORT . PROPS),
47 where:
48  - NAME is a string describing the column.
49    This is the label for the column in the header line.
50    Different columns must have non-`equal' names.
51  - WIDTH is the width to reserve for the column.
52    For the final element, its numerical value is ignored.
53  - SORT specifies how to sort entries by this column.
54    If nil, this column cannot be used for sorting.
55    If t, sort by comparing the string value printed in the column.
56    Otherwise, it should be a predicate function suitable for
57    `sort', accepting arguments with the same form as the elements
58    of `tabulated-list-entries'.
59  - PROPS is a plist of additional column properties.
60    Currently supported properties are:
61    - `:right-align': If non-nil, the column should be right-aligned.
62    - `:pad-right': Number of additional padding spaces to the
63      right of the column (defaults to 1 if omitted).")
64 (put 'tabulated-list-format 'permanent-local t)
65
66 (defvar-local tabulated-list-use-header-line t
67   "Whether the Tabulated List buffer should use a header line.")
68
69 (defvar-local tabulated-list-entries nil
70   "Entries displayed in the current Tabulated List buffer.
71 This should be either a function, or a list.
72 If a list, each element has the form (ID [DESC1 ... DESCN]),
73 where:
74  - ID is nil, or a Lisp object uniquely identifying this entry,
75    which is used to keep the cursor on the \"same\" entry when
76    rearranging the list.  Comparison is done with `equal'.
77
78  - Each DESC is a column descriptor, one for each column
79    specified in `tabulated-list-format'.  A descriptor is either
80    a string, which is printed as-is, or a list (LABEL . PROPS),
81    which means to use `insert-text-button' to insert a text
82    button with label LABEL and button properties PROPS.
83    The string, or button label, must not contain any newline.
84
85 If `tabulated-list-entries' is a function, it is called with no
86 arguments and must return a list of the above form.")
87 (put 'tabulated-list-entries 'permanent-local t)
88
89 (defvar-local tabulated-list-padding 0
90   "Number of characters preceding each Tabulated List mode entry.
91 By default, lines are padded with spaces, but you can use the
92 function `tabulated-list-put-tag' to change this.")
93 (put 'tabulated-list-padding 'permanent-local t)
94
95 (defvar tabulated-list-revert-hook nil
96   "Hook run before reverting a Tabulated List buffer.
97 This is commonly used to recompute `tabulated-list-entries'.")
98
99 (defvar-local tabulated-list-printer 'tabulated-list-print-entry
100   "Function for inserting a Tabulated List entry at point.
101 It is called with two arguments, ID and COLS.  ID is a Lisp
102 object identifying the entry, and COLS is a vector of column
103 descriptors, as documented in `tabulated-list-entries'.")
104
105 (defvar-local tabulated-list-sort-key nil
106   "Sort key for the current Tabulated List mode buffer.
107 If nil, no additional sorting is performed.
108 Otherwise, this should be a cons cell (NAME . FLIP).
109 NAME is a string matching one of the column names in
110 `tabulated-list-format' (the corresponding SORT entry in
111 `tabulated-list-format' then specifies how to sort).  FLIP, if
112 non-nil, means to invert the resulting sort.")
113 (put 'tabulated-list-sort-key 'permanent-local t)
114
115 (defsubst tabulated-list-get-id (&optional pos)
116   "Return the entry ID of the Tabulated List entry at POS.
117 The value is an ID object from `tabulated-list-entries', or nil.
118 POS, if omitted or nil, defaults to point."
119   (get-text-property (or pos (point)) 'tabulated-list-id))
120
121 (defsubst tabulated-list-get-entry (&optional pos)
122   "Return the Tabulated List entry at POS.
123 The value is a vector of column descriptors, or nil if there is
124 no entry at POS.  POS, if omitted or nil, defaults to point."
125   (get-text-property (or pos (point)) 'tabulated-list-entry))
126
127 (defun tabulated-list-put-tag (tag &optional advance)
128   "Put TAG in the padding area of the current line.
129 TAG should be a string, with length <= `tabulated-list-padding'.
130 If ADVANCE is non-nil, move forward by one line afterwards."
131   (unless (stringp tag)
132     (error "Invalid argument to `tabulated-list-put-tag'"))
133   (unless (> tabulated-list-padding 0)
134     (error "Unable to tag the current line"))
135   (save-excursion
136     (beginning-of-line)
137     (when (tabulated-list-get-entry)
138       (let ((beg (point))
139             (inhibit-read-only t))
140         (forward-char tabulated-list-padding)
141         (insert-and-inherit
142          (let ((width (string-width tag)))
143            (if (<= width tabulated-list-padding)
144                (concat tag
145                        (make-string (- tabulated-list-padding width) ?\s))
146              (truncate-string-to-width tag tabulated-list-padding))))
147         (delete-region beg (+ beg tabulated-list-padding)))))
148   (if advance
149       (forward-line)))
150
151 (defvar tabulated-list-mode-map
152   (let ((map (copy-keymap special-mode-map)))
153     (set-keymap-parent map button-buffer-map)
154     (define-key map "n" 'next-line)
155     (define-key map "p" 'previous-line)
156     (define-key map "S" 'tabulated-list-sort)
157     (define-key map [follow-link] 'mouse-face)
158     (define-key map [mouse-2] 'mouse-select-window)
159     map)
160   "Local keymap for `tabulated-list-mode' buffers.")
161
162 (defvar tabulated-list-sort-button-map
163   (let ((map (make-sparse-keymap)))
164     (define-key map [header-line mouse-1] 'tabulated-list-col-sort)
165     (define-key map [header-line mouse-2] 'tabulated-list-col-sort)
166     (define-key map [mouse-1] 'tabulated-list-col-sort)
167     (define-key map [mouse-2] 'tabulated-list-col-sort)
168     (define-key map "\C-m" 'tabulated-list-sort)
169     (define-key map [follow-link] 'mouse-face)
170     map)
171   "Local keymap for `tabulated-list-mode' sort buttons.")
172
173 (defvar tabulated-list-glyphless-char-display
174   (let ((table (make-char-table 'glyphless-char-display nil)))
175     (set-char-table-parent table glyphless-char-display)
176     ;; Some text terminals can't display the Unicode arrows; be safe.
177     (aset table 9650 (cons nil "^"))
178     (aset table 9660 (cons nil "v"))
179     table)
180   "The `glyphless-char-display' table in Tabulated List buffers.")
181
182 (defvar tabulated-list--header-string nil)
183 (defvar tabulated-list--header-overlay nil)
184
185 (defun tabulated-list-init-header ()
186   "Set up header line for the Tabulated List buffer."
187   ;; FIXME: Should share code with tabulated-list-print-col!
188   (let ((x (max tabulated-list-padding 0))
189         (button-props `(help-echo "Click to sort by column"
190                         mouse-face highlight
191                         keymap ,tabulated-list-sort-button-map))
192         (cols nil))
193     (push (propertize " " 'display `(space :align-to ,x)) cols)
194     (dotimes (n (length tabulated-list-format))
195       (let* ((col (aref tabulated-list-format n))
196              (label (nth 0 col))
197              (width (nth 1 col))
198              (props (nthcdr 3 col))
199              (pad-right (or (plist-get props :pad-right) 1))
200              (right-align (plist-get props :right-align))
201              (next-x (+ x pad-right width)))
202         (push
203          (cond
204           ;; An unsortable column
205           ((not (nth 2 col))
206            (propertize label 'tabulated-list-column-name label))
207           ;; The selected sort column
208           ((equal (car col) (car tabulated-list-sort-key))
209            (apply 'propertize
210                   (concat label
211                           (cond
212                            ((> (+ 2 (length label)) width) "")
213                            ((cdr tabulated-list-sort-key) " ▲")
214                            (t " ▼")))
215                   'face 'bold
216                   'tabulated-list-column-name label
217                   button-props))
218           ;; Unselected sortable column.
219           (t (apply 'propertize label
220                     'tabulated-list-column-name label
221                     button-props)))
222          cols)
223         (when right-align
224           (let ((shift (- width (string-width (car cols)))))
225             (when (> shift 0)
226               (setq cols
227                     (cons (car cols)
228                           (cons (propertize (make-string shift ?\s)
229                                             'display
230                                             `(space :align-to ,(+ x shift)))
231                                 (cdr cols))))
232               (setq x (+ x shift)))))
233         (if (>= pad-right 0)
234             (push (propertize " "
235                               'display `(space :align-to ,next-x)
236                               'face 'fixed-pitch)
237                   cols))
238         (setq x next-x)))
239     (setq cols (apply 'concat (nreverse cols)))
240     (if tabulated-list-use-header-line
241         (setq header-line-format cols)
242       (setq header-line-format nil)
243       (setq-local tabulated-list--header-string cols))))
244
245 (defun tabulated-list-print-fake-header ()
246   "Insert a fake Tabulated List \"header line\" at the start of the buffer."
247   (goto-char (point-min))
248   (let ((inhibit-read-only t))
249     (insert tabulated-list--header-string "\n")
250     (if tabulated-list--header-overlay
251         (move-overlay tabulated-list--header-overlay (point-min) (point))
252       (setq-local tabulated-list--header-overlay
253                   (make-overlay (point-min) (point))))
254     (overlay-put tabulated-list--header-overlay 'face 'underline)))
255
256 (defun tabulated-list-revert (&rest ignored)
257   "The `revert-buffer-function' for `tabulated-list-mode'.
258 It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
259   (interactive)
260   (unless (derived-mode-p 'tabulated-list-mode)
261     (error "The current buffer is not in Tabulated List mode"))
262   (run-hooks 'tabulated-list-revert-hook)
263   (tabulated-list-print t))
264
265 (defun tabulated-list--column-number (name)
266   (let ((len (length tabulated-list-format))
267         (n 0)
268         found)
269     (while (and (< n len) (null found))
270       (if (equal (car (aref tabulated-list-format n)) name)
271           (setq found n))
272       (setq n (1+ n)))
273     (or found
274         (error "No column named %s" name))))
275
276 (defun tabulated-list-print (&optional remember-pos)
277   "Populate the current Tabulated List mode buffer.
278 This sorts the `tabulated-list-entries' list if sorting is
279 specified by `tabulated-list-sort-key'.  It then erases the
280 buffer and inserts the entries with `tabulated-list-printer'.
281
282 Optional argument REMEMBER-POS, if non-nil, means to move point
283 to the entry with the same ID element as the current line."
284   (let ((inhibit-read-only t)
285         (entries (if (functionp tabulated-list-entries)
286                      (funcall tabulated-list-entries)
287                    tabulated-list-entries))
288         entry-id saved-pt saved-col)
289     (and remember-pos
290          (setq entry-id (tabulated-list-get-id))
291          (setq saved-col (current-column)))
292     (erase-buffer)
293     (unless tabulated-list-use-header-line
294       (tabulated-list-print-fake-header))
295     ;; Sort the entries, if necessary.
296     (when (and tabulated-list-sort-key
297                (car tabulated-list-sort-key))
298       (let* ((sort-column (car tabulated-list-sort-key))
299              (n (tabulated-list--column-number sort-column))
300              (sorter (nth 2 (aref tabulated-list-format n))))
301         ;; Is the specified column sortable?
302         (when sorter
303           (when (eq sorter t)
304             (setq sorter ; Default sorter checks column N:
305                   (lambda (A B)
306                     (setq A (aref (cadr A) n))
307                     (setq B (aref (cadr B) n))
308                     (string< (if (stringp A) A (car A))
309                              (if (stringp B) B (car B))))))
310           (setq entries (sort entries sorter))
311           (if (cdr tabulated-list-sort-key)
312               (setq entries (nreverse entries)))
313           (unless (functionp tabulated-list-entries)
314             (setq tabulated-list-entries entries)))))
315     ;; Print the resulting list.
316     (dolist (elt entries)
317       (and entry-id
318            (equal entry-id (car elt))
319            (setq saved-pt (point)))
320       (apply tabulated-list-printer elt))
321     (set-buffer-modified-p nil)
322     ;; If REMEMBER-POS was specified, move to the "old" location.
323     (if saved-pt
324         (progn (goto-char saved-pt)
325                (move-to-column saved-col)
326                (recenter))
327       (goto-char (point-min)))))
328
329 (defun tabulated-list-print-entry (id cols)
330   "Insert a Tabulated List entry at point.
331 This is the default `tabulated-list-printer' function.  ID is a
332 Lisp object identifying the entry to print, and COLS is a vector
333 of column descriptors."
334   (let ((beg   (point))
335         (x     (max tabulated-list-padding 0))
336         (ncols (length tabulated-list-format))
337         (inhibit-read-only t))
338     (if (> tabulated-list-padding 0)
339         (insert (make-string x ?\s)))
340     (dotimes (n ncols)
341       (setq x (tabulated-list-print-col n (aref cols n) x)))
342     (insert ?\n)
343     (put-text-property beg (point) 'tabulated-list-id id)
344     (put-text-property beg (point) 'tabulated-list-entry cols)))
345
346 (defun tabulated-list-print-col (n col-desc x)
347   "Insert a specified Tabulated List entry at point.
348 N is the column number, COL-DESC is a column descriptor (see
349 `tabulated-list-entries'), and X is the column number at point.
350 Return the column number after insertion."
351   ;; TODO: don't truncate to `width' if the next column is align-right
352   ;; and has some space left.
353   (let* ((format    (aref tabulated-list-format n))
354          (name      (nth 0 format))
355          (width     (nth 1 format))
356          (props     (nthcdr 3 format))
357          (pad-right (or (plist-get props :pad-right) 1))
358          (right-align (plist-get props :right-align))
359          (label     (if (stringp col-desc) col-desc (car col-desc)))
360          (label-width (string-width label))
361          (help-echo (concat (car format) ": " label))
362          (opoint (point))
363          (not-last-col (< (1+ n) (length tabulated-list-format))))
364     ;; Truncate labels if necessary (except last column).
365     (and not-last-col
366          (> label-width width)
367          (setq label (truncate-string-to-width label width nil nil t)
368                label-width width))
369     (setq label (bidi-string-mark-left-to-right label))
370     (when (and right-align (> width label-width))
371       (let ((shift (- width label-width)))
372         (insert (propertize (make-string shift ?\s)
373                             'display `(space :align-to ,(+ x shift))))
374         (setq width (- width shift))
375         (setq x (+ x shift))))
376     (if (stringp col-desc)
377         (insert (if (get-text-property 0 'help-echo label)
378                     label
379                   (propertize label 'help-echo help-echo)))
380       (apply 'insert-text-button label (cdr col-desc)))
381     (let ((next-x (+ x pad-right width)))
382       ;; No need to append any spaces if this is the last column.
383       (when not-last-col
384         (when (> pad-right 0) (insert (make-string pad-right ?\s)))
385         (insert (propertize
386                  (make-string (- next-x x label-width pad-right) ?\s)
387                  'display `(space :align-to ,next-x))))
388       (put-text-property opoint (point) 'tabulated-list-column-name name)
389       next-x)))
390
391 (defun tabulated-list-delete-entry ()
392   "Delete the Tabulated List entry at point.
393 Return a list (ID COLS), where ID is the ID of the deleted entry
394 and COLS is a vector of its column descriptors.  Move point to
395 the beginning of the deleted entry.  Return nil if there is no
396 entry at point.
397
398 This function only changes the buffer contents; it does not alter
399 `tabulated-list-entries'."
400   ;; Assume that each entry occupies one line.
401   (let* ((id (tabulated-list-get-id))
402          (cols (tabulated-list-get-entry))
403          (inhibit-read-only t))
404     (when cols
405       (delete-region (line-beginning-position) (1+ (line-end-position)))
406       (list id cols))))
407
408 (defun tabulated-list-set-col (col desc &optional change-entry-data)
409   "Change the Tabulated List entry at point, setting COL to DESC.
410 COL is the column number to change, or the name of the column to change.
411 DESC is the new column descriptor, which is inserted via
412 `tabulated-list-print-col'.
413
414 If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data
415 by setting the appropriate slot of the vector originally used to
416 print this entry.  If `tabulated-list-entries' has a list value,
417 this is the vector stored within it."
418   (let* ((opoint (point))
419          (eol    (line-end-position))
420          (pos    (line-beginning-position))
421          (id     (tabulated-list-get-id pos))
422          (entry  (tabulated-list-get-entry pos))
423          (prop 'tabulated-list-column-name)
424          (inhibit-read-only t)
425          name)
426     (cond ((numberp col)
427            (setq name (car (aref tabulated-list-format col))))
428           ((stringp col)
429            (setq name col
430                  col (tabulated-list--column-number col)))
431           (t
432            (error "Invalid column %s" col)))
433     (unless entry
434       (error "No Tabulated List entry at position %s" opoint))
435     (unless (equal (get-text-property pos prop) name)
436       (while (and (setq pos
437                         (next-single-property-change pos prop nil eol))
438                   (< pos eol)
439                   (not (equal (get-text-property pos prop) name)))))
440     (when (< pos eol)
441       (delete-region pos (next-single-property-change pos prop nil eol))
442       (goto-char pos)
443       (tabulated-list-print-col col desc (current-column))
444       (if change-entry-data
445           (aset entry col desc))
446       (put-text-property pos (point) 'tabulated-list-id id)
447       (put-text-property pos (point) 'tabulated-list-entry entry)
448       (goto-char opoint))))
449
450 (defun tabulated-list-col-sort (&optional e)
451   "Sort Tabulated List entries by the column of the mouse click E."
452   (interactive "e")
453   (let* ((pos (event-start e))
454          (obj (posn-object pos)))
455     (with-current-buffer (window-buffer (posn-window pos))
456       (tabulated-list--sort-by-column-name
457        (get-text-property (if obj (cdr obj) (posn-point pos))
458                           'tabulated-list-column-name
459                           (car obj))))))
460
461 (defun tabulated-list-sort (&optional n)
462   "Sort Tabulated List entries by the column at point.
463 With a numeric prefix argument N, sort the Nth column."
464   (interactive "P")
465   (let ((name (if n
466                   (car (aref tabulated-list-format n))
467                 (get-text-property (point)
468                                    'tabulated-list-column-name))))
469     (tabulated-list--sort-by-column-name name)))
470
471 (defun tabulated-list--sort-by-column-name (name)
472   (when (and name (derived-mode-p 'tabulated-list-mode))
473     ;; Flip the sort order on a second click.
474     (if (equal name (car tabulated-list-sort-key))
475         (setcdr tabulated-list-sort-key
476                 (not (cdr tabulated-list-sort-key)))
477       (setq tabulated-list-sort-key (cons name nil)))
478     (tabulated-list-init-header)
479     (tabulated-list-print t)))
480
481 ;;; The mode definition:
482
483 (define-derived-mode tabulated-list-mode special-mode "Tabulated"
484   "Generic major mode for browsing a list of items.
485 This mode is usually not used directly; instead, other major
486 modes are derived from it, using `define-derived-mode'.
487
488 In this major mode, the buffer is divided into multiple columns,
489 which are labeled using the header line.  Each non-empty line
490 belongs to one \"entry\", and the entries can be sorted according
491 to their column values.
492
493 An inheriting mode should usually do the following in their body:
494
495  - Set `tabulated-list-format', specifying the column format.
496  - Set `tabulated-list-revert-hook', if the buffer contents need
497    to be specially recomputed prior to `revert-buffer'.
498  - Maybe set a `tabulated-list-entries' function (see below).
499  - Maybe set `tabulated-list-printer' (see below).
500  - Maybe set `tabulated-list-padding'.
501  - Call `tabulated-list-init-header' to initialize `header-line-format'
502    according to `tabulated-list-format'.
503
504 An inheriting mode is usually accompanied by a \"list-FOO\"
505 command (e.g. `list-packages', `list-processes').  This command
506 creates or switches to a buffer and enables the major mode in
507 that buffer.  If `tabulated-list-entries' is not a function, the
508 command should initialize it to a list of entries for displaying.
509 Finally, it should call `tabulated-list-print'.
510
511 `tabulated-list-print' calls the printer function specified by
512 `tabulated-list-printer', once for each entry.  The default
513 printer is `tabulated-list-print-entry', but a mode that keeps
514 data in an ewoc may instead specify a printer function (e.g., one
515 that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
516 as the ewoc pretty-printer."
517   (setq-local truncate-lines t)
518   (setq-local buffer-read-only t)
519   (setq-local buffer-undo-list t)
520   (setq-local revert-buffer-function #'tabulated-list-revert)
521   (setq-local glyphless-char-display tabulated-list-glyphless-char-display))
522
523 (put 'tabulated-list-mode 'mode-class 'special)
524
525 (provide 'tabulated-list)
526
527 ;; Local Variables:
528 ;; coding: utf-8
529 ;; End:
530
531 ;;; tabulated-list.el ends here