lisp/emacs-lisp/tabulated-list.el

   1 ;;; tabulated-list.el --- generic major mode for tabulated lists.
   2
   3 ;; Copyright (C) 2011 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 (defun tabulated-list-init-header ()
 147   "Set up header line for the Tabulated List buffer."
 148   (let ((x tabulated-list-padding)
 149         (button-props `(help-echo "Click to sort by column"
 150                         mouse-face highlight
 151                         keymap ,tabulated-list-sort-button-map))
 152         (cols nil))
 153     (if (> tabulated-list-padding 0)
 154         (push (propertize " " 'display `(space :align-to ,x)) cols))
 155     (dotimes (n (length tabulated-list-format))
 156       (let* ((col (aref tabulated-list-format n))
 157              (width (nth 1 col))
 158              (label (car col)))
 159         (setq x (+ x 1 width))
 160         (and (<= tabulated-list-padding 0)
 161              (= n 0)
 162              (setq label (concat " " label)))
 163         (push
 164          (cond
 165           ;; An unsortable column
 166           ((not (nth 2 col)) label)
 167           ;; The selected sort column
 168           ((equal (car col) (car tabulated-list-sort-key))
 169            (apply 'propertize
 170                   (concat label
 171                           (cond
 172                            ((> (+ 2 (length label)) width)
 173                             "")
 174                            ((cdr tabulated-list-sort-key)
 175                             " ▲")
 176                            (t " ▼")))
 177                   'face 'bold
 178                   'tabulated-list-column-name (car col)
 179                   button-props))
 180           ;; Unselected sortable column.
 181           (t (apply 'propertize label
 182                     'tabulated-list-column-name (car col)
 183                     button-props)))
 184          cols))
 185       (push (propertize " "
 186                         'display (list 'space :align-to x)
 187                         'face 'fixed-pitch)
 188             cols))
 189     (setq header-line-format (mapconcat 'identity (nreverse cols) ""))))
 190
 191 (defun tabulated-list-revert (&rest ignored)
 192   "The `revert-buffer-function' for `tabulated-list-mode'.
 193 It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
 194   (interactive)
 195   (unless (derived-mode-p 'tabulated-list-mode)
 196     (error "The current buffer is not in Tabulated List mode"))
 197   (run-hooks 'tabulated-list-revert-hook)
 198   (tabulated-list-print t))
 199
 200 (defun tabulated-list-print (&optional remember-pos)
 201   "Populate the current Tabulated List mode buffer.
 202 This sorts the `tabulated-list-entries' list if sorting is
 203 specified by `tabulated-list-sort-key'.  It then erases the
 204 buffer and inserts the entries with `tabulated-list-printer'.
 205
 206 Optional argument REMEMBER-POS, if non-nil, means to move point
 207 to the entry with the same ID element as the current line."
 208   (let ((inhibit-read-only t)
 209         (entries (if (functionp 'tabulated-list-entries)
 210                      (funcall tabulated-list-entries)
 211                    tabulated-list-entries))
 212         entry-id saved-pt saved-col)
 213     (and remember-pos
 214          (setq entry-id (tabulated-list-get-id))
 215          (setq saved-col (current-column)))
 216     (erase-buffer)
 217     ;; Sort the buffers, if necessary.
 218     (when tabulated-list-sort-key
 219       (let ((sort-column (car tabulated-list-sort-key))
 220             (len (length tabulated-list-format))
 221             (n 0)
 222             sorter)
 223         ;; Which column is to be sorted?
 224         (while (and (< n len)
 225                     (not (equal (car (aref tabulated-list-format n))
 226                                 sort-column)))
 227           (setq n (1+ n)))
 228         (when (< n len)
 229           (setq sorter (nth 2 (aref tabulated-list-format n)))
 230           (when (eq sorter t)
 231             (setq sorter ; Default sorter checks column N:
 232                   (lambda (A B)
 233                     (setq A (aref (cadr A) n))
 234                     (setq B (aref (cadr B) n))
 235                     (string< (if (stringp A) A (car A))
 236                              (if (stringp B) B (car B))))))
 237           (setq entries (sort entries sorter))
 238           (if (cdr tabulated-list-sort-key)
 239               (setq entries (nreverse entries)))
 240           (unless (functionp 'tabulated-list-entries)
 241             (setq tabulated-list-entries entries)))))
 242     ;; Print the resulting list.
 243     (dolist (elt entries)
 244       (and entry-id
 245            (equal entry-id (car elt))
 246            (setq saved-pt (point)))
 247       (apply tabulated-list-printer elt))
 248     (set-buffer-modified-p nil)
 249     ;; If REMEMBER-POS was specified, move to the "old" location.
 250     (if saved-pt
 251         (progn (goto-char saved-pt)
 252                (move-to-column saved-col))
 253       (goto-char (point-min)))))
 254
 255 (defun tabulated-list-print-entry (id cols)
 256   "Insert a Tabulated List entry at point.
 257 This is the default `tabulated-list-printer' function.  ID is a
 258 Lisp object identifying the entry to print, and COLS is a vector
 259 of column descriptors."
 260   (let ((beg (point))
 261         (x (max tabulated-list-padding 0))
 262         (len (length tabulated-list-format)))
 263     (if (> tabulated-list-padding 0)
 264         (insert (make-string x ?\s)))
 265     (dotimes (n len)
 266       (let* ((format (aref tabulated-list-format n))
 267              (desc   (aref cols n))
 268              (width  (nth 1 format))
 269              (label  (if (stringp desc) desc (car desc)))
 270              (help-echo (concat (car format) ": " label)))
 271         ;; Truncate labels if necessary.
 272         (and (> width 6)
 273              (> (length label) width)
 274              (setq label (concat (substring desc 0 (- width 3))
 275                                  "...")))
 276         (if (stringp desc)
 277             (insert (propertize label 'help-echo help-echo))
 278           (apply 'insert-text-button label (cdr desc)))
 279         (setq x (+ x 1 width)))
 280       ;; No need to append any spaces if this is the last column.
 281       (if (< (1+ n) len)
 282           (indent-to x 1)))
 283     (insert ?\n)
 284     (put-text-property beg (point) 'tabulated-list-id id)))
 285
 286 (defun tabulated-list-col-sort (&optional e)
 287   "Sort Tabulated List entries by the column of the mouse click E."
 288   (interactive "e")
 289   (let* ((pos (event-start e))
 290          (obj (posn-object pos))
 291          (name (get-text-property (if obj (cdr obj) (posn-point pos))
 292                                   'tabulated-list-column-name
 293                                   (car obj))))
 294     (with-current-buffer (window-buffer (posn-window pos))
 295       (when (derived-mode-p 'tabulated-list-mode)
 296         ;; Flip the sort order on a second click.
 297         (if (equal name (car tabulated-list-sort-key))
 298             (setcdr tabulated-list-sort-key
 299                     (not (cdr tabulated-list-sort-key)))
 300           (setq tabulated-list-sort-key (cons name nil)))
 301         (tabulated-list-init-header)
 302         (tabulated-list-print t)))))
 303
 304 ;;; The mode definition:
 305
 306 ;;;###autoload
 307 (define-derived-mode tabulated-list-mode special-mode "Tabulated"
 308   "Generic major mode for browsing a list of items.
 309 This mode is usually not used directly; instead, other major
 310 modes are derived from it, using `define-derived-mode'.
 311
 312 In this major mode, the buffer is divided into multiple columns,
 313 which are labelled using the header line.  Each non-empty line
 314 belongs to one \"entry\", and the entries can be sorted according
 315 to their column values.
 316
 317 An inheriting mode should usually do the following in their body:
 318
 319  - Set `tabulated-list-format', specifying the column format.
 320  - Set `tabulated-list-revert-hook', if the buffer contents need
 321    to be specially recomputed prior to `revert-buffer'.
 322  - Maybe set a `tabulated-list-entries' function (see below).
 323  - Maybe set `tabulated-list-printer' (see below).
 324  - Maybe set `tabulated-list-padding'.
 325  - Call `tabulated-list-init-header' to initialize `header-line-format'
 326    according to `tabulated-list-format'.
 327
 328 An inheriting mode is usually accompanied by a \"list-FOO\"
 329 command (e.g. `list-packages', `list-processes').  This command
 330 creates or switches to a buffer and enables the major mode in
 331 that buffer.  If `tabulated-list-entries' is not a function, the
 332 command should initialize it to a list of entries for displaying.
 333 Finally, it should call `tabulated-list-print'.
 334
 335 `tabulated-list-print' calls the printer function specified by
 336 `tabulated-list-printer', once for each entry.  The default
 337 printer is `tabulated-list-print-entry', but a mode that keeps
 338 data in an ewoc may instead specify a printer function (e.g., one
 339 that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
 340 as the ewoc pretty-printer."
 341   (setq truncate-lines t)
 342   (setq buffer-read-only t)
 343   (set (make-local-variable 'revert-buffer-function)
 344        'tabulated-list-revert))
 345
 346 (put 'tabulated-list-mode 'mode-class 'special)
 347
 348 (provide 'tabulated-list)
 349
 350 ;; Local Variables:
 351 ;; coding: utf-8
 352 ;; lexical-binding: t
 353 ;; End:
 354
 355 ;;; tabulated-list.el ends here