lisp/emacs-lisp/tabulated-list.el

   1 ;;; tabulated-list.el --- generic major mode for tabulated lists.
   2
   3 ;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Chong Yidong <cyd@stupidchicken.com>
   6 ;; Keywords: extensions, lisp
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This file defines `tabulated-list-mode', a generic major mode for displaying
  26 ;; lists of tabulated data, intended for other major modes to inherit from.  It
  27 ;; provides several utility routines, e.g. for pretty-printing lines of
  28 ;; tabulated data to fit into the appropriate columns.
  29
  30 ;; For usage information, see the documentation of `tabulated-list-mode'.
  31
  32 ;; This package originated from Tom Tromey's Package Menu mode, extended and
  33 ;; generalized to be used by other modes.
  34
  35 ;;; Code:
  36
  37 (defvar tabulated-list-format nil
  38   "The format of the current Tabulated List mode buffer.
  39 This should be a vector of elements (NAME WIDTH SORT), where:
  40  - NAME is a string describing the column.
  41  - WIDTH is the width to reserve for the column.
  42    For the final element, its numerical value is ignored.
  43  - SORT specifies how to sort entries by this column.
  44    If nil, this column cannot be used for sorting.
  45    If t, sort by comparing the string value printed in the column.
  46    Otherwise, it should be a predicate function suitable for
  47    `sort', accepting arguments with the same form as the elements
  48    of `tabulated-list-entries'.")
  49 (make-variable-buffer-local 'tabulated-list-format)
  50
  51 (defvar tabulated-list-entries nil
  52   "Entries displayed in the current Tabulated List buffer.
  53 This should be either a function, or a list.
  54 If a list, each element has the form (ID [DESC1 ... DESCN]),
  55 where:
  56  - ID is nil, or a Lisp object uniquely identifying this entry,
  57    which is used to keep the cursor on the \"same\" entry when
  58    rearranging the list.  Comparison is done with `equal'.
  59
  60  - Each DESC is a column descriptor, one for each column
  61    specified in `tabulated-list-format'.  A descriptor is either
  62    a string, which is printed as-is, or a list (LABEL . PROPS),
  63    which means to use `insert-text-button' to insert a text
  64    button with label LABEL and button properties PROPS.
  65    The string, or button label, must not contain any newline.
  66
  67 If `tabulated-list-entries' is a function, it is called with no
  68 arguments and must return a list of the above form.")
  69 (make-variable-buffer-local 'tabulated-list-entries)
  70
  71 (defvar tabulated-list-padding 0
  72   "Number of characters preceding each Tabulated List mode entry.
  73 By default, lines are padded with spaces, but you can use the
  74 function `tabulated-list-put-tag' to change this.")
  75 (make-variable-buffer-local 'tabulated-list-padding)
  76
  77 (defvar tabulated-list-revert-hook nil
  78   "Hook run before reverting a Tabulated List buffer.
  79 This is commonly used to recompute `tabulated-list-entries'.")
  80
  81 (defvar tabulated-list-printer 'tabulated-list-print-entry
  82   "Function for inserting a Tabulated List entry at point.
  83 It is called with two arguments, ID and COLS.  ID is a Lisp
  84 object identifying the entry, and COLS is a vector of column
  85 descriptors, as documented in `tabulated-list-entries'.")
  86 (make-variable-buffer-local 'tabulated-list-printer)
  87
  88 (defvar tabulated-list-sort-key nil
  89   "Sort key for the current Tabulated List mode buffer.
  90 If nil, no additional sorting is performed.
  91 Otherwise, this should be a cons cell (NAME . FLIP).
  92 NAME is a string matching one of the column names in
  93 `tabulated-list-format' (the corresponding SORT entry in
  94 `tabulated-list-format' then specifies how to sort).  FLIP, if
  95 non-nil, means to invert the resulting sort.")
  96 (make-variable-buffer-local 'tabulated-list-sort-key)
  97
  98 (defun tabulated-list-get-id (&optional pos)
  99   "Obtain the entry ID of the Tabulated List mode entry at POS.
 100 This is an ID object from `tabulated-list-entries', or nil.
 101 POS, if omitted or nil, defaults to point."
 102   (get-text-property (or pos (point)) 'tabulated-list-id))
 103
 104 (defun tabulated-list-put-tag (tag &optional advance)
 105   "Put TAG in the padding area of the current line.
 106 TAG should be a string, with length <= `tabulated-list-padding'.
 107 If ADVANCE is non-nil, move forward by one line afterwards."
 108   (unless (stringp tag)
 109     (error "Invalid argument to `tabulated-list-put-tag'"))
 110   (unless (> tabulated-list-padding 0)
 111     (error "Unable to tag the current line"))
 112   (save-excursion
 113     (beginning-of-line)
 114     (when (get-text-property (point) 'tabulated-list-id)
 115       (let ((beg (point))
 116             (inhibit-read-only t))
 117         (forward-char tabulated-list-padding)
 118         (insert-and-inherit
 119          (if (<= (length tag) tabulated-list-padding)
 120              (concat tag
 121                      (make-string (- tabulated-list-padding (length tag))
 122                                   ?\s))
 123            (substring tag 0 tabulated-list-padding)))
 124         (delete-region beg (+ beg tabulated-list-padding)))))
 125   (if advance
 126       (forward-line)))
 127
 128 (defvar tabulated-list-mode-map
 129   (let ((map (copy-keymap special-mode-map)))
 130     (set-keymap-parent map button-buffer-map)
 131     (define-key map "n" 'next-line)
 132     (define-key map "p" 'previous-line)
 133     (define-key map [follow-link] 'mouse-face)
 134     (define-key map [mouse-2] 'mouse-select-window)
 135     map)
 136   "Local keymap for `tabulated-list-mode' buffers.")
 137
 138 (defvar tabulated-list-sort-button-map
 139   (let ((map (make-sparse-keymap)))
 140     (define-key map [header-line mouse-1] 'tabulated-list-col-sort)
 141     (define-key map [header-line mouse-2] 'tabulated-list-col-sort)
 142     (define-key map [follow-link] 'mouse-face)
 143     map)
 144   "Local keymap for `tabulated-list-mode' sort buttons.")
 145
 146 (defvar tabulated-list-glyphless-char-display
 147   (let ((table (make-char-table 'glyphless-char-display nil)))
 148     (set-char-table-parent table glyphless-char-display)
 149     ;; Some text terminals can't display the Unicode arrows; be safe.
 150     (aset table 9650 (cons nil "^"))
 151     (aset table 9660 (cons nil "v"))
 152     table)
 153   "The `glyphless-char-display' table in Tabulated List buffers.")
 154
 155 (defun tabulated-list-init-header ()
 156   "Set up header line for the Tabulated List buffer."
 157   (let ((x tabulated-list-padding)
 158         (button-props `(help-echo "Click to sort by column"
 159                         mouse-face highlight
 160                         keymap ,tabulated-list-sort-button-map))
 161         (cols nil))
 162     (if (> tabulated-list-padding 0)
 163         (push (propertize " " 'display `(space :align-to ,x)) cols))
 164     (dotimes (n (length tabulated-list-format))
 165       (let* ((col (aref tabulated-list-format n))
 166              (width (nth 1 col))
 167              (label (car col)))
 168         (setq x (+ x 1 width))
 169         (and (<= tabulated-list-padding 0)
 170              (= n 0)
 171              (setq label (concat " " label)))
 172         (push
 173          (cond
 174           ;; An unsortable column
 175           ((not (nth 2 col)) label)
 176           ;; The selected sort column
 177           ((equal (car col) (car tabulated-list-sort-key))
 178            (apply 'propertize
 179                   (concat label
 180                           (cond
 181                            ((> (+ 2 (length label)) width)
 182                             "")
 183                            ((cdr tabulated-list-sort-key)
 184                             " ▲")
 185                            (t " ▼")))
 186                   'face 'bold
 187                   'tabulated-list-column-name (car col)
 188                   button-props))
 189           ;; Unselected sortable column.
 190           (t (apply 'propertize label
 191                     'tabulated-list-column-name (car col)
 192                     button-props)))
 193          cols))
 194       (push (propertize " "
 195                         'display (list 'space :align-to x)
 196                         'face 'fixed-pitch)
 197             cols))
 198     (setq header-line-format (mapconcat 'identity (nreverse cols) ""))))
 199
 200 (defun tabulated-list-revert (&rest ignored)
 201   "The `revert-buffer-function' for `tabulated-list-mode'.
 202 It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
 203   (interactive)
 204   (unless (derived-mode-p 'tabulated-list-mode)
 205     (error "The current buffer is not in Tabulated List mode"))
 206   (run-hooks 'tabulated-list-revert-hook)
 207   (tabulated-list-print t))
 208
 209 (defun tabulated-list-print (&optional remember-pos)
 210   "Populate the current Tabulated List mode buffer.
 211 This sorts the `tabulated-list-entries' list if sorting is
 212 specified by `tabulated-list-sort-key'.  It then erases the
 213 buffer and inserts the entries with `tabulated-list-printer'.
 214
 215 Optional argument REMEMBER-POS, if non-nil, means to move point
 216 to the entry with the same ID element as the current line."
 217   (let ((inhibit-read-only t)
 218         (entries (if (functionp 'tabulated-list-entries)
 219                      (funcall tabulated-list-entries)
 220                    tabulated-list-entries))
 221         entry-id saved-pt saved-col)
 222     (and remember-pos
 223          (setq entry-id (tabulated-list-get-id))
 224          (setq saved-col (current-column)))
 225     (erase-buffer)
 226     ;; Sort the buffers, if necessary.
 227     (when tabulated-list-sort-key
 228       (let ((sort-column (car tabulated-list-sort-key))
 229             (len (length tabulated-list-format))
 230             (n 0)
 231             sorter)
 232         ;; Which column is to be sorted?
 233         (while (and (< n len)
 234                     (not (equal (car (aref tabulated-list-format n))
 235                                 sort-column)))
 236           (setq n (1+ n)))
 237         (when (< n len)
 238           (setq sorter (nth 2 (aref tabulated-list-format n)))
 239           (when (eq sorter t)
 240             (setq sorter ; Default sorter checks column N:
 241                   (lambda (A B)
 242                     (setq A (aref (cadr A) n))
 243                     (setq B (aref (cadr B) n))
 244                     (string< (if (stringp A) A (car A))
 245                              (if (stringp B) B (car B))))))
 246           (setq entries (sort entries sorter))
 247           (if (cdr tabulated-list-sort-key)
 248               (setq entries (nreverse entries)))
 249           (unless (functionp 'tabulated-list-entries)
 250             (setq tabulated-list-entries entries)))))
 251     ;; Print the resulting list.
 252     (dolist (elt entries)
 253       (and entry-id
 254            (equal entry-id (car elt))
 255            (setq saved-pt (point)))
 256       (apply tabulated-list-printer elt))
 257     (set-buffer-modified-p nil)
 258     ;; If REMEMBER-POS was specified, move to the "old" location.
 259     (if saved-pt
 260         (progn (goto-char saved-pt)
 261                (move-to-column saved-col)
 262                (recenter))
 263       (goto-char (point-min)))))
 264
 265 (defun tabulated-list-print-entry (id cols)
 266   "Insert a Tabulated List entry at point.
 267 This is the default `tabulated-list-printer' function.  ID is a
 268 Lisp object identifying the entry to print, and COLS is a vector
 269 of column descriptors."
 270   (let ((beg (point))
 271         (x (max tabulated-list-padding 0))
 272         (len (length tabulated-list-format)))
 273     (if (> tabulated-list-padding 0)
 274         (insert (make-string x ?\s)))
 275     (dotimes (n len)
 276       (let* ((format (aref tabulated-list-format n))
 277              (desc   (aref cols n))
 278              (width  (nth 1 format))
 279              (label  (if (stringp desc) desc (car desc)))
 280              (help-echo (concat (car format) ": " label)))
 281         ;; Truncate labels if necessary.
 282         (and (> width 6)
 283              (> (length label) width)
 284              (setq label (concat (substring label 0 (- width 3))
 285                                  "...")))
 286         (setq label (bidi-string-mark-left-to-right label))
 287         (if (stringp desc)
 288             (insert (propertize label 'help-echo help-echo))
 289           (apply 'insert-text-button label (cdr desc)))
 290         (setq x (+ x 1 width)))
 291       ;; No need to append any spaces if this is the last column.
 292       (if (< (1+ n) len)
 293           (indent-to x 1)))
 294     (insert ?\n)
 295     (put-text-property beg (point) 'tabulated-list-id id)))
 296
 297 (defun tabulated-list-col-sort (&optional e)
 298   "Sort Tabulated List entries by the column of the mouse click E."
 299   (interactive "e")
 300   (let* ((pos (event-start e))
 301          (obj (posn-object pos))
 302          (name (get-text-property (if obj (cdr obj) (posn-point pos))
 303                                   'tabulated-list-column-name
 304                                   (car obj))))
 305     (with-current-buffer (window-buffer (posn-window pos))
 306       (when (derived-mode-p 'tabulated-list-mode)
 307         ;; Flip the sort order on a second click.
 308         (if (equal name (car tabulated-list-sort-key))
 309             (setcdr tabulated-list-sort-key
 310                     (not (cdr tabulated-list-sort-key)))
 311           (setq tabulated-list-sort-key (cons name nil)))
 312         (tabulated-list-init-header)
 313         (tabulated-list-print t)))))
 314
 315 ;;; The mode definition:
 316
 317 ;;;###autoload
 318 (define-derived-mode tabulated-list-mode special-mode "Tabulated"
 319   "Generic major mode for browsing a list of items.
 320 This mode is usually not used directly; instead, other major
 321 modes are derived from it, using `define-derived-mode'.
 322
 323 In this major mode, the buffer is divided into multiple columns,
 324 which are labeled using the header line.  Each non-empty line
 325 belongs to one \"entry\", and the entries can be sorted according
 326 to their column values.
 327
 328 An inheriting mode should usually do the following in their body:
 329
 330  - Set `tabulated-list-format', specifying the column format.
 331  - Set `tabulated-list-revert-hook', if the buffer contents need
 332    to be specially recomputed prior to `revert-buffer'.
 333  - Maybe set a `tabulated-list-entries' function (see below).
 334  - Maybe set `tabulated-list-printer' (see below).
 335  - Maybe set `tabulated-list-padding'.
 336  - Call `tabulated-list-init-header' to initialize `header-line-format'
 337    according to `tabulated-list-format'.
 338
 339 An inheriting mode is usually accompanied by a \"list-FOO\"
 340 command (e.g. `list-packages', `list-processes').  This command
 341 creates or switches to a buffer and enables the major mode in
 342 that buffer.  If `tabulated-list-entries' is not a function, the
 343 command should initialize it to a list of entries for displaying.
 344 Finally, it should call `tabulated-list-print'.
 345
 346 `tabulated-list-print' calls the printer function specified by
 347 `tabulated-list-printer', once for each entry.  The default
 348 printer is `tabulated-list-print-entry', but a mode that keeps
 349 data in an ewoc may instead specify a printer function (e.g., one
 350 that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
 351 as the ewoc pretty-printer."
 352   (setq truncate-lines t)
 353   (setq buffer-read-only t)
 354   (set (make-local-variable 'revert-buffer-function)
 355        'tabulated-list-revert)
 356   (set (make-local-variable 'glyphless-char-display)
 357        tabulated-list-glyphless-char-display))
 358
 359 (put 'tabulated-list-mode 'mode-class 'special)
 360
 361 (provide 'tabulated-list)
 362
 363 ;; Local Variables:
 364 ;; coding: utf-8
 365 ;; lexical-binding: t
 366 ;; End:
 367
 368 ;;; tabulated-list.el ends here