emacs/guix-list.el

   1 ;;; guix-list.el --- List buffers for displaying entries   -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014 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 a list-like buffer for displaying information
  23 ;; about Guix packages and generations.
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28 (require 'tabulated-list)
  29 (require 'guix-info)
  30 (require 'guix-history)
  31 (require 'guix-base)
  32 (require 'guix-utils)
  33
  34 (defgroup guix-list nil
  35   "General settings for list buffers."
  36   :prefix "guix-list-"
  37   :group 'guix)
  38
  39 (defface guix-list-file-path
  40   '((t :inherit guix-info-file-path))
  41   "Face used for file paths."
  42   :group 'guix-list)
  43
  44 (defcustom guix-list-describe-warning-count 10
  45   "The maximum number of entries for describing without a warning.
  46 If a user wants to describe more than this number of marked
  47 entries, he will be prompted for confirmation."
  48   :type 'integer
  49   :group 'guix-list)
  50
  51 (defvar guix-list-column-format
  52   `((package
  53      (name 20 t)
  54      (version 10 nil)
  55      (outputs 13 t)
  56      (installed 13 t)
  57      (synopsis 30 nil))
  58     (generation
  59      (number 5
  60              ,(lambda (a b) (guix-list-sort-numerically 0 a b))
  61              :right-align t)
  62      (time 20 t)
  63      (path 30 t)))
  64   "Columns displayed in list buffers.
  65 Each element of the list has a form:
  66
  67   (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...))
  68
  69 PARAM is the name of an entry parameter of ENTRY-TYPE.  For the
  70 meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.")
  71
  72 (defvar guix-list-column-titles
  73   '((generation
  74      (number . "N.")))
  75   "Column titles for list buffers.
  76 Has the same structure as `guix-param-titles', but titles from
  77 this list have a priority.")
  78
  79 (defvar guix-list-column-value-methods
  80   '((package
  81      (name        . guix-package-list-get-name)
  82      (synopsis    . guix-list-get-one-line)
  83      (description . guix-list-get-one-line)
  84      (installed   . guix-package-list-get-installed-outputs))
  85     (generation
  86      (time . guix-list-get-time)
  87      (path . guix-list-get-file-path)))
  88   "Methods for inserting parameter values in columns.
  89 Each element of the list has a form:
  90
  91   (ENTRY-TYPE . ((PARAM . FUN) ...))
  92
  93 PARAM is the name of an entry parameter of ENTRY-TYPE.
  94
  95 FUN is a function returning a value that will be inserted.  The
  96 function is called with 2 arguments: the first one is the value
  97 of the parameter; the second argument is an entry info (alist of
  98 parameters and their values).")
  99
 100 (defun guix-list-get-param-title (entry-type param)
 101   "Return title of an ENTRY-TYPE entry parameter PARAM."
 102   (or (guix-get-key-val guix-list-column-titles
 103                         entry-type param)
 104       (guix-get-param-title entry-type param)))
 105
 106 (defun guix-list-get-column-format (entry-type)
 107   "Return column format for ENTRY-TYPE."
 108   (guix-get-key-val guix-list-column-format entry-type))
 109
 110 (defun guix-list-get-displayed-params (entry-type)
 111   "Return list of parameters of ENTRY-TYPE that should be displayed."
 112   (mapcar #'car
 113           (guix-list-get-column-format entry-type)))
 114
 115 (defun guix-list-get-sort-key (entry-type param &optional invert)
 116   "Return suitable sort key for `tabulated-list-sort-key'.
 117 Define column title by ENTRY-TYPE and PARAM.  If INVERT is
 118 non-nil, invert the sort."
 119   (when (memq param (guix-list-get-displayed-params entry-type))
 120     (cons (guix-list-get-param-title entry-type param) invert)))
 121
 122 (defun guix-list-sort-numerically (column a b)
 123   "Compare COLUMN of tabulated entries A and B numerically.
 124 It is a sort predicate for `tabulated-list-format'.
 125 Return non-nil, if B is bigger than A."
 126   (cl-flet ((num (entry)
 127               (string-to-number (aref (cadr entry) column))))
 128     (> (num b) (num a))))
 129
 130 (defun guix-list-make-tabulated-vector (entry-type fun)
 131   "Call FUN on each column specification for ENTRY-TYPE.
 132
 133 FUN is called with 2 argument: parameter name and column
 134 specification (see `guix-list-column-format').
 135
 136 Return a vector made of values of FUN calls."
 137   (apply #'vector
 138          (mapcar (lambda (col-spec)
 139                    (funcall fun (car col-spec) (cdr col-spec)))
 140                  (guix-list-get-column-format entry-type))))
 141
 142 (defun guix-list-get-list-format (entry-type)
 143   "Return ENTRY-TYPE list specification for `tabulated-list-format'."
 144   (guix-list-make-tabulated-vector
 145    entry-type
 146    (lambda (param spec)
 147      (cons (guix-list-get-param-title entry-type param)
 148            spec))))
 149
 150 (defun guix-list-insert-entries (entries entry-type)
 151   "Display ENTRIES of ENTRY-TYPE in the current list buffer.
 152 ENTRIES should have a form of `guix-entries'."
 153   (setq tabulated-list-entries
 154         (guix-list-get-tabulated-entries entries entry-type))
 155   (tabulated-list-print))
 156
 157 (defun guix-list-get-tabulated-entries (entries entry-type)
 158   "Return list of values of ENTRY-TYPE for `tabulated-list-entries'.
 159 Values are taken from ENTRIES which should have the form of
 160 `guix-entries'."
 161   (mapcar (lambda (entry)
 162             (list (guix-get-key-val entry 'id)
 163                   (guix-list-get-tabulated-entry entry entry-type)))
 164           entries))
 165
 166 (defun guix-list-get-tabulated-entry (entry entry-type)
 167   "Return array of values for `tabulated-list-entries'.
 168 Parameters are taken from ENTRY of ENTRY-TYPE."
 169   (guix-list-make-tabulated-vector
 170    entry-type
 171    (lambda (param _)
 172      (let ((val (guix-get-key-val entry param))
 173            (fun (guix-get-key-val guix-list-column-value-methods
 174                                   entry-type param)))
 175        (if (and val fun)
 176            (funcall fun val entry)
 177          (guix-get-string val))))))
 178
 179 (defun guix-list-get-one-line (str &optional _)
 180   "Return one-line string from a multi-line STR."
 181   (guix-get-one-line str))
 182
 183 (defun guix-list-get-time (seconds &optional _)
 184   "Return formatted time string from SECONDS."
 185   (guix-get-time-string seconds))
 186
 187 (defun guix-list-get-file-path (path &optional _)
 188   "Return PATH button specification for `tabulated-list-entries'."
 189   (list path
 190         'face 'guix-list-file-path
 191         'action (lambda (btn) (find-file (button-label btn)))
 192         'follow-link t
 193         'help-echo "Find file"))
 194
 195 (defun guix-list-current-id ()
 196   "Return ID of the current entry."
 197   (or (tabulated-list-get-id)
 198       (user-error "No entry here")))
 199
 200 (defun guix-list-current-entry ()
 201   "Return alist of the current entry info."
 202   (guix-get-entry-by-id (guix-list-current-id) guix-entries))
 203
 204 (defun guix-list-for-each-line (fun &rest args)
 205   "Call FUN with ARGS for each entry line."
 206   (or (derived-mode-p 'guix-list-mode)
 207       (error "The current buffer is not in Guix List mode"))
 208   (save-excursion
 209     (goto-char (point-min))
 210     (while (not (eobp))
 211       (apply fun args)
 212       (forward-line))))
 213
 214 (defun guix-list-fold-lines (fun init)
 215   "Fold over entry lines in the current list buffer.
 216 Call FUN with RESULT as argument for each line, using INIT as
 217 the initial value of RESULT.  Return the final result."
 218   (let ((res init))
 219     (guix-list-for-each-line
 220      (lambda () (setq res (funcall fun res))))
 221     res))
 222
 223 \f
 224 ;;; Marking and sorting
 225
 226 (defvar-local guix-list-marked nil
 227   "List of the marked entries.
 228 Each element of the list has a form:
 229
 230   (ID MARK-NAME . ARGS)
 231
 232 ID is an entry ID.
 233 MARK-NAME is a symbol from `guix-list-mark-alist'.
 234 ARGS is a list of additional values.")
 235
 236 (defvar guix-list-mark-alist
 237   '((empty   . ?\s)
 238     (general . ?*))
 239   "Alist of available mark names and mark characters.")
 240
 241 (defsubst guix-list-get-mark (name)
 242   "Return mark character by its NAME."
 243   (or (guix-get-key-val guix-list-mark-alist name)
 244       (error "Mark '%S' not found" name)))
 245
 246 (defsubst guix-list-get-mark-string (name)
 247   "Return mark string by its NAME."
 248   (string (guix-list-get-mark name)))
 249
 250 (defun guix-list-current-mark ()
 251   "Return mark character of the current line."
 252   (char-after (line-beginning-position)))
 253
 254 (defun guix-list-get-marked (&rest mark-names)
 255   "Return list of specs of entries marked with any mark from MARK-NAMES.
 256 Entry specs are elements from `guix-list-marked' list.
 257 If MARK-NAMES are not specified, use all marks from
 258 `guix-list-mark-alist' except the `empty' one."
 259   (or mark-names
 260       (setq mark-names
 261             (delq 'empty
 262                   (mapcar #'car guix-list-mark-alist))))
 263   (cl-remove-if-not (lambda (assoc)
 264                       (memq (cadr assoc) mark-names))
 265                     guix-list-marked))
 266
 267 (defun guix-list-get-marked-args (mark-name)
 268   "Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
 269 See `guix-list-marked' for the meaning of ARGS."
 270   (mapcar (lambda (spec)
 271             (let ((id (car spec))
 272                   (args (cddr spec)))
 273               (cons id args)))
 274           (guix-list-get-marked mark-name)))
 275
 276 (defun guix-list-get-marked-id-list (&rest mark-names)
 277   "Return list of IDs of entries marked with any mark from MARK-NAMES.
 278 See `guix-list-get-marked' for details."
 279   (mapcar #'car (apply #'guix-list-get-marked mark-names)))
 280
 281 (defun guix-list-mark (mark-name &optional advance &rest args)
 282   "Put a mark on the current line.
 283 Also add the current entry to `guix-list-marked' using its ID and ARGS.
 284 MARK-NAME is a symbol from `guix-list-mark-alist'.
 285 If ADVANCE is non-nil, move forward by one line after marking.
 286 Interactively, put a general mark and move to the next line."
 287   (interactive '(general t))
 288   (let ((id (guix-list-current-id)))
 289     (if (eq mark-name 'empty)
 290         (setq guix-list-marked (assq-delete-all id guix-list-marked))
 291       (let ((assoc (assq id guix-list-marked))
 292             (val (cons mark-name args)))
 293         (if assoc
 294             (setcdr assoc val)
 295           (push (cons id val) guix-list-marked)))))
 296   (tabulated-list-put-tag (guix-list-get-mark-string mark-name)
 297                           advance))
 298
 299 (defun guix-list-mark-all (mark-name)
 300   "Mark all lines with MARK-NAME mark.
 301 MARK-NAME is a symbol from `guix-list-mark-alist'.
 302 Interactively, put a general mark on all lines."
 303   (interactive '(general))
 304   (guix-list-for-each-line #'guix-list-mark mark-name))
 305
 306 (defun guix-list-unmark ()
 307   "Unmark the current line and move to the next line."
 308   (interactive)
 309   (guix-list-mark 'empty t))
 310
 311 (defun guix-list-unmark-backward ()
 312   "Move up one line and unmark it."
 313   (interactive)
 314   (forward-line -1)
 315   (guix-list-mark 'empty))
 316
 317 (defun guix-list-unmark-all ()
 318   "Unmark all lines."
 319   (interactive)
 320   (guix-list-mark-all 'empty))
 321
 322 (defun guix-list-restore-marks ()
 323   "Put marks according to `guix-list-mark-alist'."
 324   (guix-list-for-each-line
 325    (lambda ()
 326      (let ((mark-name (car (guix-get-key-val guix-list-marked
 327                                              (guix-list-current-id)))))
 328        (tabulated-list-put-tag
 329         (guix-list-get-mark-string (or mark-name 'empty)))))))
 330
 331 (defun guix-list-sort (&optional n)
 332   "Sort guix list entries by the column at point.
 333 With a numeric prefix argument N, sort the Nth column.
 334 Same as `tabulated-list-sort', but also restore marks after sorting."
 335   (interactive "P")
 336   (tabulated-list-sort n)
 337   (guix-list-restore-marks))
 338
 339 \f
 340 (defvar guix-list-mode-map
 341   (let ((map (make-sparse-keymap)))
 342     (set-keymap-parent map tabulated-list-mode-map)
 343     (define-key map (kbd "m")   'guix-list-mark)
 344     (define-key map (kbd "*")   'guix-list-mark)
 345     (define-key map (kbd "M")   'guix-list-mark-all)
 346     (define-key map (kbd "u")   'guix-list-unmark)
 347     (define-key map (kbd "U")   'guix-list-unmark-all)
 348     (define-key map (kbd "DEL") 'guix-list-unmark-backward)
 349     (define-key map [remap tabulated-list-sort] 'guix-list-sort)
 350     map)
 351   "Parent keymap for list buffers.")
 352
 353 (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
 354   "Parent mode for displaying information in list buffers."
 355   (setq tabulated-list-padding 2))
 356
 357 (defmacro guix-list-define-entry-type (entry-type &rest args)
 358   "Define common stuff for displaying ENTRY-TYPE entries in list buffers.
 359
 360 Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
 361 following keywords are available:
 362
 363   - `:sort-key' - default sort key for the tabulated list buffer.
 364
 365   - `:invert-sort' - if non-nil, invert initial sort.
 366
 367   - `:marks' - default value for the defined
 368     `guix-ENTRY-TYPE-mark-alist' variable.
 369
 370 This macro defines the following functions:
 371
 372   - `guix-ENTRY-TYPE-describe' - display marked entries in info buffer.
 373
 374   - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark
 375     specified in `:marks' argument."
 376   (let* ((entry-type-str (symbol-name entry-type))
 377          (entry-str      (concat entry-type-str " entries"))
 378          (prefix         (concat "guix-" entry-type-str "-list"))
 379          (mode-str       (concat prefix "-mode"))
 380          (init-fun       (intern (concat prefix "-mode-initialize")))
 381          (describe-fun   (intern (concat prefix "-describe")))
 382          (marks-var      (intern (concat prefix "-mark-alist")))
 383          (marks-val      nil)
 384          (sort-key       nil)
 385          (invert-sort    nil))
 386
 387     ;; Process the keyword args.
 388     (while (keywordp (car args))
 389       (pcase (pop args)
 390         (`:sort-key    (setq sort-key (pop args)))
 391         (`:invert-sort (setq invert-sort (pop args)))
 392         (`:marks       (setq marks-val (pop args)))
 393         (_ (pop args))))
 394
 395     `(progn
 396        (defvar ,marks-var ',marks-val
 397          ,(concat "Alist of additional marks for `" mode-str "'.\n"
 398                   "Marks from this list are added to `guix-list-mark-alist'."))
 399
 400        ,@(mapcar (lambda (mark-spec)
 401                    (let* ((mark-name (car mark-spec))
 402                           (mark-name-str (symbol-name mark-name)))
 403                      `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) ()
 404                         ,(concat "Put '" mark-name-str "' mark and move to the next line.\n"
 405                                  "Also add the current entry to `guix-list-marked'.")
 406                         (interactive)
 407                         (guix-list-mark ',mark-name t))))
 408                  marks-val)
 409
 410        (defun ,describe-fun (&optional arg)
 411          ,(concat "Describe " entry-str " marked with a general mark.\n"
 412                   "If no entry is marked, describe the current " entry-type-str ".\n"
 413                   "With prefix (if ARG is non-nil), describe the " entry-str "\n"
 414                   "marked with any mark.")
 415          (interactive "P")
 416          (let* ((ids (or (apply #'guix-list-get-marked-id-list
 417                                 (unless arg '(general)))
 418                          (list (guix-list-current-id))))
 419                 (count (length ids)))
 420            (when (or (<= count guix-list-describe-warning-count)
 421                      (y-or-n-p (format "Do you really want to describe %d entries? "
 422                                        count)))
 423              (,(intern (concat "guix-" entry-type-str "-info-get-show"))
 424               'id ids))))
 425
 426        (defun ,init-fun ()
 427          ,(concat "Initial settings for `" mode-str "'.")
 428          ,(when sort-key
 429             `(setq tabulated-list-sort-key
 430                    (guix-list-get-sort-key
 431                     ',entry-type ',sort-key ,invert-sort)))
 432          (setq tabulated-list-format
 433                (guix-list-get-list-format ',entry-type))
 434          (setq-local guix-list-mark-alist
 435                      (append guix-list-mark-alist ,marks-var))
 436          (tabulated-list-init-header)))))
 437
 438 (put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
 439
 440 \f
 441 ;;; Displaying packages
 442
 443 (guix-define-buffer-type list package)
 444
 445 (guix-list-define-entry-type package
 446   :sort-key name
 447   :marks ((install . ?I)
 448           (upgrade . ?U)
 449           (delete  . ?D)))
 450
 451 (defface guix-package-list-obsolete
 452   '((t :inherit guix-package-info-obsolete))
 453   "Face used if a package is obsolete."
 454   :group 'guix-package-list)
 455
 456 (defcustom guix-package-list-generation-marking-enabled nil
 457   "If non-nil, allow putting marks in a list with 'generation packages'.
 458
 459 By default this is disabled, because it may be confusing.  For
 460 example a package is installed in some generation, so a user can
 461 mark it for deletion in the list of packages from this
 462 generation, but the package may not be installed in the latest
 463 generation, so actually it cannot be deleted.
 464
 465 If you managed to understand the explanation above or if you
 466 really know what you do or if you just don't care, you can set
 467 this variable to t.  It should not do much harm anyway (most
 468 likely)."
 469   :type 'boolean
 470   :group 'guix-package-list)
 471
 472 (let ((map guix-package-list-mode-map))
 473   (define-key map (kbd "RET") 'guix-package-list-describe)
 474   (define-key map (kbd "x")   'guix-package-list-execute)
 475   (define-key map (kbd "i")   'guix-package-list-mark-install)
 476   (define-key map (kbd "^")   'guix-package-list-mark-upgrade)
 477   (define-key map (kbd "d")   'guix-package-list-mark-delete))
 478
 479 (defun guix-package-list-get-name (name entry)
 480   "Return NAME of the package ENTRY.
 481 Colorize it with `guix-package-list-obsolete' if needed."
 482   (guix-get-string name
 483                    (when (guix-get-key-val entry 'obsolete)
 484                      'guix-package-list-obsolete)))
 485
 486 (defun guix-package-list-get-installed-outputs (installed &optional _)
 487   "Return string with outputs from INSTALLED entries."
 488   (guix-get-string
 489    (mapcar (lambda (entry)
 490              (guix-get-key-val entry 'output))
 491            installed)))
 492
 493 (defun guix-package-list-marking-check ()
 494   "Signal an error if marking is disabled for the current buffer."
 495   (when (and (not guix-package-list-generation-marking-enabled)
 496              (derived-mode-p 'guix-package-list-mode)
 497              (eq guix-search-type 'generation))
 498     (error "Action marks are disabled for lists of 'generation packages'")))
 499
 500 (defun guix-package-list-mark-install (&optional arg)
 501   "Mark the current package for installation and move to the next line.
 502 With ARG, prompt for the outputs to install (several outputs may
 503 be separated with \",\")."
 504   (interactive "P")
 505   (guix-package-list-marking-check)
 506   (let* ((entry (guix-list-current-entry))
 507          (available (guix-get-key-val entry 'outputs))
 508          (installed (guix-get-installed-outputs entry))
 509          (to-install (if arg
 510                          (guix-completing-read-multiple
 511                           "Output(s) to install: " available nil t)
 512                        '("out")))
 513          (to-install (cl-set-difference to-install installed
 514                                         :test #'string=)))
 515     (if to-install
 516         (apply #'guix-list-mark 'install t to-install)
 517       (user-error "This package is already installed"))))
 518
 519 (defun guix-package-list-mark-delete (&optional arg)
 520   "Mark the current package for deletion and move to the next line.
 521 With ARG, prompt for the outputs to delete (several outputs may
 522 be separated with \",\")."
 523   (interactive "P")
 524   (guix-package-list-marking-check)
 525   (let* ((entry (guix-list-current-entry))
 526          (installed (guix-get-installed-outputs entry)))
 527     (or installed
 528         (user-error "This package is not installed"))
 529     (let ((to-delete (when arg
 530                        (guix-completing-read-multiple
 531                         "Output(s) to delete: " installed nil t))))
 532       (if to-delete
 533           (apply #'guix-list-mark 'delete t to-delete)
 534         (guix-package-list-mark-delete-simple)))))
 535
 536 (defun guix-package-list-mark-upgrade ()
 537   "Mark the current package for upgrading and move to the next line."
 538   (interactive)
 539   (guix-package-list-marking-check)
 540   (let ((entry (guix-list-current-entry)))
 541     (or (guix-get-installed-outputs entry)
 542         (user-error "This package is not installed"))
 543     (when (or (guix-get-key-val entry 'obsolete)
 544               (y-or-n-p "This package is not obsolete.  Try to upgrade it anyway? "))
 545       (guix-package-list-mark-upgrade-simple))))
 546
 547 (defun guix-package-list-execute ()
 548   "Perform actions on the marked packages."
 549   (interactive)
 550   (let ((actions (delq nil
 551                        (mapcar #'guix-package-list-make-action
 552                                '(install delete upgrade)))))
 553     (if actions
 554         (apply #'guix-process-package-actions actions)
 555       (user-error "No operations specified"))))
 556
 557 (defun guix-package-list-make-action (action-type)
 558   "Return action specification for the packages marked with ACTION-TYPE.
 559 Return nil, if there are no packages marked with ACTION-TYPE.
 560 The specification is suitable for `guix-process-package-actions'."
 561   (let ((specs (guix-list-get-marked-args action-type)))
 562     (and specs (cons action-type specs))))
 563
 564 \f
 565 ;;; Displaying generations
 566
 567 (guix-define-buffer-type list generation)
 568
 569 (guix-list-define-entry-type generation
 570   :sort-key number
 571   :invert-sort t
 572   :marks ((delete . ?D)))
 573
 574 (let ((map guix-generation-list-mode-map))
 575   (define-key map (kbd "RET") 'guix-generation-list-show-packages)
 576   (define-key map (kbd "i")   'guix-generation-list-describe)
 577   (define-key map (kbd "d")   'guix-generation-list-mark-delete-simple))
 578
 579 (defun guix-generation-list-show-packages ()
 580   "List installed packages for the generation at point."
 581   (interactive)
 582   (guix-package-list-get-show 'generation (guix-list-current-id)))
 583
 584 (provide 'guix-list)
 585
 586 ;;; guix-list.el ends here