emacs/guix-list.el

   1 ;;; guix-list.el --- 'List' buffer interface for displaying data  -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
   4
   5 ;; This file is part of GNU Guix.
   6
   7 ;; GNU Guix is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Guix is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This file provides 'list' buffer interface for displaying an arbitrary
  23 ;; data.
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28 (require 'tabulated-list)
  29 (require 'guix-buffer)
  30 (require 'guix-info)
  31 (require 'guix-entry)
  32 (require 'guix-utils)
  33
  34 (guix-define-buffer-type list)
  35
  36 (defface guix-list-file-name
  37   '((t :inherit guix-info-file-name))
  38   "Face used for file names."
  39   :group 'guix-list-faces)
  40
  41 (defface guix-list-url
  42   '((t :inherit guix-info-url))
  43   "Face used for URLs."
  44   :group 'guix-list-faces)
  45
  46 (defface guix-list-time
  47   '((t :inherit guix-info-time))
  48   "Face used for time stamps."
  49   :group 'guix-list-faces)
  50
  51 (defun guix-list-describe (&optional mark-names)
  52   "Describe entries marked with a general mark.
  53 'Describe' means display entries in 'info' buffer.
  54 If no entries are marked, describe the current entry.
  55 With prefix argument, describe entries marked with any mark."
  56   (interactive (list (unless current-prefix-arg '(general))))
  57   (let* ((ids        (or (apply #'guix-list-get-marked-id-list mark-names)
  58                          (list (guix-list-current-id))))
  59          (count      (length ids))
  60          (entry-type (guix-buffer-current-entry-type)))
  61     (when (or (<= count (guix-list-describe-warning-count entry-type))
  62               (y-or-n-p (format "Do you really want to describe %d entries? "
  63                                 count)))
  64       (guix-list-describe-entries entry-type ids))))
  65
  66 \f
  67 ;;; Wrappers for 'list' variables
  68
  69 (defvar guix-list-data nil
  70   "Alist with 'list' data.
  71 This alist is filled by `guix-list-define-interface' macro.")
  72
  73 (defun guix-list-value (entry-type symbol)
  74   "Return SYMBOL's value for ENTRY-TYPE from `guix-list-data'."
  75   (symbol-value (guix-assq-value guix-list-data entry-type symbol)))
  76
  77 (defun guix-list-param-title (entry-type param)
  78   "Return column title of an ENTRY-TYPE parameter PARAM."
  79   (guix-buffer-param-title 'list entry-type param))
  80
  81 (defun guix-list-format (entry-type)
  82   "Return column format for ENTRY-TYPE."
  83   (guix-list-value entry-type 'format))
  84
  85 (defun guix-list-displayed-params (entry-type)
  86   "Return a list of ENTRY-TYPE parameters that should be displayed."
  87   (mapcar #'car (guix-list-format entry-type)))
  88
  89 (defun guix-list-sort-key (entry-type)
  90   "Return sort key for ENTRY-TYPE."
  91   (guix-list-value entry-type 'sort-key))
  92
  93 (defun guix-list-additional-marks (entry-type)
  94   "Return alist of additional marks for ENTRY-TYPE."
  95   (guix-list-value entry-type 'marks))
  96
  97 (defun guix-list-single-entry? (entry-type)
  98   "Return non-nil, if a single entry of ENTRY-TYPE should be listed."
  99   (guix-list-value entry-type 'list-single))
 100
 101 (defun guix-list-describe-warning-count (entry-type)
 102   "Return the maximum number of ENTRY-TYPE entries to describe."
 103   (guix-list-value entry-type 'describe-count))
 104
 105 (defun guix-list-describe-entries (entry-type ids)
 106   "Describe ENTRY-TYPE entries with IDS in 'info' buffer"
 107   (funcall (guix-list-value entry-type 'describe)
 108            ids))
 109
 110 \f
 111 ;;; Tabulated list internals
 112
 113 (defun guix-list-sort-numerically (column a b)
 114   "Compare COLUMN of tabulated entries A and B numerically.
 115 This function is used for sort predicates for `tabulated-list-format'.
 116 Return non-nil, if B is bigger than A."
 117   (cl-flet ((num (entry)
 118               (string-to-number (aref (cadr entry) column))))
 119     (> (num b) (num a))))
 120
 121 (defmacro guix-list-define-numerical-sorter (column)
 122   "Define numerical sort predicate for COLUMN.
 123 See `guix-list-sort-numerically' for details."
 124   (let ((name (intern (format "guix-list-sort-numerically-%d" column)))
 125         (doc  (format "\
 126 Predicate to sort tabulated list by column %d numerically.
 127 See `guix-list-sort-numerically' for details."
 128                       column)))
 129     `(defun ,name (a b)
 130        ,doc
 131        (guix-list-sort-numerically ,column a b))))
 132
 133 (defmacro guix-list-define-numerical-sorters (n)
 134   "Define numerical sort predicates for columns from 0 to N.
 135 See `guix-list-define-numerical-sorter' for details."
 136   `(progn
 137      ,@(mapcar (lambda (i)
 138                  `(guix-list-define-numerical-sorter ,i))
 139                (number-sequence 0 n))))
 140
 141 (guix-list-define-numerical-sorters 9)
 142
 143 (defun guix-list-tabulated-sort-key (entry-type)
 144   "Return ENTRY-TYPE sort key for `tabulated-list-sort-key'."
 145   (let ((sort-key (guix-list-sort-key entry-type)))
 146     (and sort-key
 147          (cons (guix-list-param-title entry-type (car sort-key))
 148                (cdr sort-key)))))
 149
 150 (defun guix-list-tabulated-vector (entry-type fun)
 151   "Call FUN on each column specification for ENTRY-TYPE.
 152
 153 FUN is applied to column specification as arguments (see
 154 `guix-list-format').
 155
 156 Return a vector made of values of FUN calls."
 157   (apply #'vector
 158          (mapcar (lambda (col-spec)
 159                    (apply fun col-spec))
 160                  (guix-list-format entry-type))))
 161
 162 (defun guix-list-tabulated-format (entry-type)
 163   "Return ENTRY-TYPE list specification for `tabulated-list-format'."
 164   (guix-list-tabulated-vector
 165    entry-type
 166    (lambda (param _ &rest rest-spec)
 167      (cons (guix-list-param-title entry-type param)
 168            rest-spec))))
 169
 170 (defun guix-list-tabulated-entries (entries entry-type)
 171   "Return a list of ENTRY-TYPE values for `tabulated-list-entries'."
 172   (mapcar (lambda (entry)
 173             (list (guix-entry-id entry)
 174                   (guix-list-tabulated-entry entry entry-type)))
 175           entries))
 176
 177 (defun guix-list-tabulated-entry (entry entry-type)
 178   "Return array of values for `tabulated-list-entries'.
 179 Parameters are taken from ENTRY-TYPE ENTRY."
 180   (guix-list-tabulated-vector
 181    entry-type
 182    (lambda (param fun &rest _)
 183      (let ((val (guix-entry-value entry param)))
 184        (if fun
 185            (funcall fun val entry)
 186          (guix-get-string val))))))
 187
 188 \f
 189 ;;; Displaying entries
 190
 191 (defun guix-list-get-display-entries (entry-type &rest args)
 192   "Search for entries and show them in a 'list' buffer preferably."
 193   (let ((entries (guix-buffer-get-entries 'list entry-type args)))
 194     (if (or (null entries)      ; = 0
 195             (cdr entries)       ; > 1
 196             (guix-list-single-entry? entry-type)
 197             (null (guix-buffer-value 'info entry-type 'show-entries)))
 198         (guix-buffer-display-entries entries 'list entry-type args 'add)
 199       (if (equal (guix-buffer-value 'info entry-type 'get-entries)
 200                  (guix-buffer-value 'list entry-type 'get-entries))
 201           (guix-buffer-display-entries entries 'info entry-type args 'add)
 202         (guix-buffer-get-display-entries 'info entry-type args 'add)))))
 203
 204 (defun guix-list-insert-entries (entries entry-type)
 205   "Print ENTRY-TYPE ENTRIES in the current buffer."
 206   (setq tabulated-list-entries
 207         (guix-list-tabulated-entries entries entry-type))
 208   (tabulated-list-print))
 209
 210 (defun guix-list-get-one-line (val &optional _)
 211   "Return one-line string from a multi-line string VAL.
 212 VAL may be nil."
 213   (if val
 214       (guix-get-one-line val)
 215     (guix-get-string nil)))
 216
 217 (defun guix-list-get-time (seconds &optional _)
 218   "Return formatted time string from SECONDS."
 219   (guix-get-string (guix-get-time-string seconds)
 220                    'guix-list-time))
 221
 222 (defun guix-list-get-file-name (file-name &optional _)
 223   "Return FILE-NAME button specification for `tabulated-list-entries'."
 224   (list file-name
 225         'face 'guix-list-file-name
 226         'action (lambda (btn) (find-file (button-label btn)))
 227         'follow-link t
 228         'help-echo "Find file"))
 229
 230 (defun guix-list-get-url (url &optional _)
 231   "Return URL button specification for `tabulated-list-entries'."
 232   (list url
 233         'face 'guix-list-url
 234         'action (lambda (btn) (browse-url (button-label btn)))
 235         'follow-link t
 236         'help-echo "Browse URL"))
 237
 238 \f
 239 ;;; 'List' lines
 240
 241 (defun guix-list-current-id ()
 242   "Return ID of the entry at point."
 243   (or (tabulated-list-get-id)
 244       (user-error "No entry here")))
 245
 246 (defun guix-list-current-entry ()
 247   "Return entry at point."
 248   (guix-entry-by-id (guix-list-current-id)
 249                     (guix-buffer-current-entries)))
 250
 251 (defun guix-list-for-each-line (fun &rest args)
 252   "Call FUN with ARGS for each entry line."
 253   (or (derived-mode-p 'guix-list-mode)
 254       (error "The current buffer is not in Guix List mode"))
 255   (save-excursion
 256     (goto-char (point-min))
 257     (while (not (eobp))
 258       (apply fun args)
 259       (forward-line))))
 260
 261 (defun guix-list-fold-lines (fun init)
 262   "Fold over entry lines in the current list buffer.
 263 Call FUN with RESULT as argument for each line, using INIT as
 264 the initial value of RESULT.  Return the final result."
 265   (let ((res init))
 266     (guix-list-for-each-line
 267      (lambda () (setq res (funcall fun res))))
 268     res))
 269
 270 \f
 271 ;;; Marking and sorting
 272
 273 (defvar-local guix-list-marked nil
 274   "List of the marked entries.
 275 Each element of the list has a form:
 276
 277   (ID MARK-NAME . ARGS)
 278
 279 ID is an entry ID.
 280 MARK-NAME is a symbol from `guix-list-marks'.
 281 ARGS is a list of additional values.")
 282
 283 (defvar-local guix-list-marks nil
 284   "Alist of available mark names and mark characters.")
 285
 286 (defvar guix-list-default-marks
 287   '((empty   . ?\s)
 288     (general . ?*))
 289   "Alist of default mark names and mark characters.")
 290
 291 (defun guix-list-marks (entry-type)
 292   "Return alist of available marks for ENTRY-TYPE."
 293   (append guix-list-default-marks
 294           (guix-list-additional-marks entry-type)))
 295
 296 (defun guix-list-get-mark (name)
 297   "Return mark character by its NAME."
 298   (or (guix-assq-value guix-list-marks name)
 299       (error "Mark '%S' not found" name)))
 300
 301 (defun guix-list-get-mark-string (name)
 302   "Return mark string by its NAME."
 303   (string (guix-list-get-mark name)))
 304
 305 (defun guix-list-current-mark ()
 306   "Return mark character of the current line."
 307   (char-after (line-beginning-position)))
 308
 309 (defun guix-list-get-marked (&rest mark-names)
 310   "Return list of specs of entries marked with any mark from MARK-NAMES.
 311 Entry specs are elements from `guix-list-marked' list.
 312 If MARK-NAMES are not specified, use all marks from
 313 `guix-list-marks' except the `empty' one."
 314   (or mark-names
 315       (setq mark-names
 316             (delq 'empty
 317                   (mapcar #'car guix-list-marks))))
 318   (cl-remove-if-not (lambda (assoc)
 319                       (memq (cadr assoc) mark-names))
 320                     guix-list-marked))
 321
 322 (defun guix-list-get-marked-args (mark-name)
 323   "Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
 324 See `guix-list-marked' for the meaning of ARGS."
 325   (mapcar (lambda (spec)
 326             (let ((id (car spec))
 327                   (args (cddr spec)))
 328               (cons id args)))
 329           (guix-list-get-marked mark-name)))
 330
 331 (defun guix-list-get-marked-id-list (&rest mark-names)
 332   "Return list of IDs of entries marked with any mark from MARK-NAMES.
 333 See `guix-list-get-marked' for details."
 334   (mapcar #'car (apply #'guix-list-get-marked mark-names)))
 335
 336 (defun guix-list--mark (mark-name &optional advance &rest args)
 337   "Put a mark on the current line.
 338 Also add the current entry to `guix-list-marked' using its ID and ARGS.
 339 MARK-NAME is a symbol from `guix-list-marks'.
 340 If ADVANCE is non-nil, move forward by one line after marking."
 341   (let ((id (guix-list-current-id)))
 342     (if (eq mark-name 'empty)
 343         (setq guix-list-marked (assq-delete-all id guix-list-marked))
 344       (let ((assoc (assq id guix-list-marked))
 345             (val (cons mark-name args)))
 346         (if assoc
 347             (setcdr assoc val)
 348           (push (cons id val) guix-list-marked)))))
 349   (tabulated-list-put-tag (guix-list-get-mark-string mark-name)
 350                           advance))
 351
 352 (defun guix-list-mark (&optional arg)
 353   "Mark the current line and move to the next line.
 354 With ARG, mark all lines."
 355   (interactive "P")
 356   (if arg
 357       (guix-list-mark-all)
 358     (guix-list--mark 'general t)))
 359
 360 (defun guix-list-mark-all (&optional mark-name)
 361   "Mark all lines with MARK-NAME mark.
 362 MARK-NAME is a symbol from `guix-list-marks'.
 363 Interactively, put a general mark on all lines."
 364   (interactive)
 365   (or mark-name (setq mark-name 'general))
 366   (guix-list-for-each-line #'guix-list--mark mark-name))
 367
 368 (defun guix-list-unmark (&optional arg)
 369   "Unmark the current line and move to the next line.
 370 With ARG, unmark all lines."
 371   (interactive "P")
 372   (if arg
 373       (guix-list-unmark-all)
 374     (guix-list--mark 'empty t)))
 375
 376 (defun guix-list-unmark-backward ()
 377   "Move up one line and unmark it."
 378   (interactive)
 379   (forward-line -1)
 380   (guix-list--mark 'empty))
 381
 382 (defun guix-list-unmark-all ()
 383   "Unmark all lines."
 384   (interactive)
 385   (guix-list-mark-all 'empty))
 386
 387 (defun guix-list-restore-marks ()
 388   "Put marks according to `guix-list-marked'."
 389   (guix-list-for-each-line
 390    (lambda ()
 391      (let ((mark-name (car (guix-assq-value guix-list-marked
 392                                             (guix-list-current-id)))))
 393        (tabulated-list-put-tag
 394         (guix-list-get-mark-string (or mark-name 'empty)))))))
 395
 396 (defun guix-list-sort (&optional n)
 397   "Sort guix list entries by the column at point.
 398 With a numeric prefix argument N, sort the Nth column.
 399 Same as `tabulated-list-sort', but also restore marks after sorting."
 400   (interactive "P")
 401   (tabulated-list-sort n)
 402   (guix-list-restore-marks))
 403
 404 \f
 405 ;;; Major mode and interface definer
 406
 407 (defvar guix-list-mode-map
 408   (let ((map (make-sparse-keymap)))
 409     (set-keymap-parent
 410      map (make-composed-keymap guix-buffer-map
 411                                tabulated-list-mode-map))
 412     (define-key map (kbd "RET") 'guix-list-describe)
 413     (define-key map (kbd "i")   'guix-list-describe)
 414     (define-key map (kbd "m")   'guix-list-mark)
 415     (define-key map (kbd "*")   'guix-list-mark)
 416     (define-key map (kbd "u")   'guix-list-unmark)
 417     (define-key map (kbd "DEL") 'guix-list-unmark-backward)
 418     (define-key map [remap tabulated-list-sort] 'guix-list-sort)
 419     map)
 420   "Keymap for `guix-list-mode' buffers.")
 421
 422 (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
 423   "Parent mode for displaying data in 'list' form.")
 424
 425 (defun guix-list-mode-initialize (entry-type)
 426   "Set up the current 'list' buffer for displaying ENTRY-TYPE entries."
 427   (setq tabulated-list-padding  2
 428         tabulated-list-format   (guix-list-tabulated-format entry-type)
 429         tabulated-list-sort-key (guix-list-tabulated-sort-key entry-type))
 430   (setq-local guix-list-marks   (guix-list-marks entry-type))
 431   (tabulated-list-init-header))
 432
 433 (defmacro guix-list-define-interface (entry-type &rest args)
 434   "Define 'list' interface for displaying ENTRY-TYPE entries.
 435 Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ...
 436
 437 Required keywords:
 438
 439   - `:format' - default value of the generated
 440     `guix-ENTRY-TYPE-list-format' variable.
 441
 442 Optional keywords:
 443
 444   - `:sort-key' - default value of the generated
 445     `guix-ENTRY-TYPE-list-sort-key' variable.
 446
 447   - `:describe-function' - default value of the generated
 448     `guix-ENTRY-TYPE-describe-function' variable.
 449
 450   - `:list-single?' - default value of the generated
 451     `guix-ENTRY-TYPE-list-single' variable.
 452
 453   - `:marks' - default value of the generated
 454     `guix-ENTRY-TYPE-list-marks' variable.
 455
 456 The rest keyword arguments are passed to
 457 `guix-buffer-define-interface' macro."
 458   (declare (indent 1))
 459   (let* ((entry-type-str     (symbol-name entry-type))
 460          (prefix             (concat "guix-" entry-type-str "-list"))
 461          (group              (intern prefix))
 462          (describe-var       (intern (concat prefix "-describe-function")))
 463          (describe-count-var (intern (concat prefix
 464                                              "-describe-warning-count")))
 465          (format-var         (intern (concat prefix "-format")))
 466          (sort-key-var       (intern (concat prefix "-sort-key")))
 467          (list-single-var    (intern (concat prefix "-single")))
 468          (marks-var          (intern (concat prefix "-marks"))))
 469     (guix-keyword-args-let args
 470         ((show-entries-val   :show-entries-function)
 471          (describe-val       :describe-function)
 472          (describe-count-val :describe-count 10)
 473          (format-val         :format)
 474          (sort-key-val       :sort-key)
 475          (list-single-val    :list-single?)
 476          (marks-val          :marks))
 477       `(progn
 478          (defcustom ,format-var ,format-val
 479            ,(format "\
 480 List of format values of the displayed columns.
 481 Each element of the list has a form:
 482
 483   (PARAM VALUE-FUN WIDTH SORT . PROPS)
 484
 485 PARAM is a name of '%s' entry parameter.
 486
 487 VALUE-FUN may be either nil or a function returning a value that
 488 will be inserted.  The function is called with 2 arguments: the
 489 first one is the value of the parameter; the second one is an
 490 entry (alist of parameter names and values).
 491
 492 For the meaning of WIDTH, SORT and PROPS, see
 493 `tabulated-list-format'."
 494                     entry-type-str)
 495            :type 'sexp
 496            :group ',group)
 497
 498          (defcustom ,sort-key-var ,sort-key-val
 499            ,(format "\
 500 Default sort key for 'list' buffer with '%s' entries.
 501 Should be nil (no sort) or have a form:
 502
 503   (PARAM . FLIP)
 504
 505 PARAM is the name of '%s' entry parameter.  For the meaning of
 506 FLIP, see `tabulated-list-sort-key'."
 507                     entry-type-str entry-type-str)
 508            :type '(choice (const :tag "No sort" nil)
 509                           (cons symbol boolean))
 510            :group ',group)
 511
 512          (defvar ,marks-var ,marks-val
 513            ,(format "\
 514 Alist of additional marks for 'list' buffer with '%s' entries.
 515 Marks from this list are used along with `guix-list-default-marks'."
 516                     entry-type-str))
 517
 518          (defcustom ,list-single-var ,list-single-val
 519            ,(format "\
 520 If non-nil, list '%s' entry even if it is the only matching result.
 521 If nil, show a single '%s' entry in the 'info' buffer."
 522                     entry-type-str entry-type-str)
 523            :type 'boolean
 524            :group ',group)
 525
 526          (defcustom ,describe-count-var ,describe-count-val
 527            ,(format "\
 528 The maximum number of '%s' entries to describe without a warning.
 529 If a user wants to describe more than this number of marked
 530 entries, he will be prompted for confirmation.
 531 See also `guix-list-describe'."
 532                     entry-type-str)
 533            :type 'integer
 534            :group ',group)
 535
 536          (defvar ,describe-var ,describe-val
 537            ,(format "Function used to describe '%s' entries."
 538                     entry-type-str))
 539
 540          (guix-alist-put!
 541           '((describe       . ,describe-var)
 542             (describe-count . ,describe-count-var)
 543             (format         . ,format-var)
 544             (sort-key       . ,sort-key-var)
 545             (list-single    . ,list-single-var)
 546             (marks          . ,marks-var))
 547           'guix-list-data ',entry-type)
 548
 549          ,(if show-entries-val
 550               `(guix-buffer-define-interface list ,entry-type
 551                  :show-entries-function ,show-entries-val
 552                  ,@%foreign-args)
 553
 554             (let ((insert-fun    (intern (concat prefix "-insert-entries")))
 555                   (mode-init-fun (intern (concat prefix "-mode-initialize"))))
 556               `(progn
 557                  (defun ,insert-fun (entries)
 558                    ,(format "\
 559 Print '%s' ENTRIES in the current 'list' buffer."
 560                             entry-type-str)
 561                    (guix-list-insert-entries entries ',entry-type))
 562
 563                  (defun ,mode-init-fun ()
 564                    ,(format "\
 565 Set up the current 'list' buffer for displaying '%s' entries."
 566                             entry-type-str)
 567                    (guix-list-mode-initialize ',entry-type))
 568
 569                  (guix-buffer-define-interface list ,entry-type
 570                    :insert-entries-function ',insert-fun
 571                    :mode-init-function ',mode-init-fun
 572                    ,@%foreign-args))))))))
 573
 574 \f
 575 (defvar guix-list-font-lock-keywords
 576   (eval-when-compile
 577     `((,(rx "(" (group "guix-list-define-interface")
 578             symbol-end)
 579        . 1))))
 580
 581 (font-lock-add-keywords 'emacs-lisp-mode guix-list-font-lock-keywords)
 582
 583 (provide 'guix-list)
 584
 585 ;;; guix-list.el ends here