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-base)
  31 (require 'guix-utils)
  32
  33 (defgroup guix-list nil
  34   "General settings for list buffers."
  35   :prefix "guix-list-"
  36   :group 'guix)
  37
  38 (defface guix-list-file-path
  39   '((t :inherit guix-info-file-path))
  40   "Face used for file paths."
  41   :group 'guix-list)
  42
  43 (defcustom guix-list-describe-warning-count 10
  44   "The maximum number of entries for describing without a warning.
  45 If a user wants to describe more than this number of marked
  46 entries, he will be prompted for confirmation."
  47   :type 'integer
  48   :group 'guix-list)
  49
  50 (defvar guix-list-column-format
  51   `((package
  52      (name 20 t)
  53      (version 10 nil)
  54      (outputs 13 t)
  55      (installed 13 t)
  56      (synopsis 30 nil))
  57     (output
  58      (name 20 t)
  59      (version 10 nil)
  60      (output 9 t)
  61      (installed 12 t)
  62      (synopsis 30 nil))
  63     (generation
  64      (number 5
  65              ,(lambda (a b) (guix-list-sort-numerically 0 a b))
  66              :right-align t)
  67      (current 10 t)
  68      (time 20 t)
  69      (path 30 t)))
  70   "Columns displayed in list buffers.
  71 Each element of the list has a form:
  72
  73   (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...))
  74
  75 PARAM is the name of an entry parameter of ENTRY-TYPE.  For the
  76 meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.")
  77
  78 (defvar guix-list-column-titles
  79   '((generation
  80      (number . "N.")))
  81   "Column titles for list buffers.
  82 Has the same structure as `guix-param-titles', but titles from
  83 this list have a priority.")
  84
  85 (defvar guix-list-column-value-methods
  86   '((package
  87      (name        . guix-package-list-get-name)
  88      (synopsis    . guix-list-get-one-line)
  89      (description . guix-list-get-one-line)
  90      (installed   . guix-package-list-get-installed-outputs))
  91     (output
  92      (name        . guix-package-list-get-name)
  93      (synopsis    . guix-list-get-one-line)
  94      (description . guix-list-get-one-line))
  95     (generation
  96      (current     . guix-generation-list-get-current)
  97      (time        . guix-list-get-time)
  98      (path        . guix-list-get-file-path)))
  99   "Methods for inserting parameter values in columns.
 100 Each element of the list has a form:
 101
 102   (ENTRY-TYPE . ((PARAM . FUN) ...))
 103
 104 PARAM is the name of an entry parameter of ENTRY-TYPE.
 105
 106 FUN is a function returning a value that will be inserted.  The
 107 function is called with 2 arguments: the first one is the value
 108 of the parameter; the second argument is an entry info (alist of
 109 parameters and their values).")
 110
 111 (defun guix-list-get-param-title (entry-type param)
 112   "Return title of an ENTRY-TYPE entry parameter PARAM."
 113   (or (guix-get-key-val guix-list-column-titles
 114                         entry-type param)
 115       (guix-get-param-title entry-type param)))
 116
 117 (defun guix-list-get-column-format (entry-type)
 118   "Return column format for ENTRY-TYPE."
 119   (guix-get-key-val guix-list-column-format entry-type))
 120
 121 (defun guix-list-get-displayed-params (entry-type)
 122   "Return list of parameters of ENTRY-TYPE that should be displayed."
 123   (mapcar #'car
 124           (guix-list-get-column-format entry-type)))
 125
 126 (defun guix-list-get-sort-key (entry-type param &optional invert)
 127   "Return suitable sort key for `tabulated-list-sort-key'.
 128 Define column title by ENTRY-TYPE and PARAM.  If INVERT is
 129 non-nil, invert the sort."
 130   (when (memq param (guix-list-get-displayed-params entry-type))
 131     (cons (guix-list-get-param-title entry-type param) invert)))
 132
 133 (defun guix-list-sort-numerically (column a b)
 134   "Compare COLUMN of tabulated entries A and B numerically.
 135 It is a sort predicate for `tabulated-list-format'.
 136 Return non-nil, if B is bigger than A."
 137   (cl-flet ((num (entry)
 138               (string-to-number (aref (cadr entry) column))))
 139     (> (num b) (num a))))
 140
 141 (defun guix-list-make-tabulated-vector (entry-type fun)
 142   "Call FUN on each column specification for ENTRY-TYPE.
 143
 144 FUN is called with 2 argument: parameter name and column
 145 specification (see `guix-list-column-format').
 146
 147 Return a vector made of values of FUN calls."
 148   (apply #'vector
 149          (mapcar (lambda (col-spec)
 150                    (funcall fun (car col-spec) (cdr col-spec)))
 151                  (guix-list-get-column-format entry-type))))
 152
 153 (defun guix-list-get-list-format (entry-type)
 154   "Return ENTRY-TYPE list specification for `tabulated-list-format'."
 155   (guix-list-make-tabulated-vector
 156    entry-type
 157    (lambda (param spec)
 158      (cons (guix-list-get-param-title entry-type param)
 159            spec))))
 160
 161 (defun guix-list-insert-entries (entries entry-type)
 162   "Display ENTRIES of ENTRY-TYPE in the current list buffer.
 163 ENTRIES should have a form of `guix-entries'."
 164   (setq tabulated-list-entries
 165         (guix-list-get-tabulated-entries entries entry-type))
 166   (tabulated-list-print))
 167
 168 (defun guix-list-get-tabulated-entries (entries entry-type)
 169   "Return list of values of ENTRY-TYPE for `tabulated-list-entries'.
 170 Values are taken from ENTRIES which should have the form of
 171 `guix-entries'."
 172   (mapcar (lambda (entry)
 173             (list (guix-get-key-val entry 'id)
 174                   (guix-list-get-tabulated-entry entry entry-type)))
 175           entries))
 176
 177 (defun guix-list-get-tabulated-entry (entry entry-type)
 178   "Return array of values for `tabulated-list-entries'.
 179 Parameters are taken from ENTRY of ENTRY-TYPE."
 180   (guix-list-make-tabulated-vector
 181    entry-type
 182    (lambda (param _)
 183      (let ((val (guix-get-key-val entry param))
 184            (fun (guix-get-key-val guix-list-column-value-methods
 185                                   entry-type param)))
 186        (if fun
 187            (funcall fun val entry)
 188          (guix-get-string val))))))
 189
 190 (defun guix-list-get-one-line (val &optional _)
 191   "Return one-line string from a multi-line string VAL.
 192 VAL may be nil."
 193   (if val
 194       (guix-get-one-line val)
 195     (guix-get-string nil)))
 196
 197 (defun guix-list-get-time (seconds &optional _)
 198   "Return formatted time string from SECONDS."
 199   (guix-get-time-string seconds))
 200
 201 (defun guix-list-get-file-path (path &optional _)
 202   "Return PATH button specification for `tabulated-list-entries'."
 203   (list path
 204         'face 'guix-list-file-path
 205         'action (lambda (btn) (find-file (button-label btn)))
 206         'follow-link t
 207         'help-echo "Find file"))
 208
 209 (defun guix-list-current-id ()
 210   "Return ID of the current entry."
 211   (or (tabulated-list-get-id)
 212       (user-error "No entry here")))
 213
 214 (defun guix-list-current-entry ()
 215   "Return alist of the current entry info."
 216   (guix-get-entry-by-id (guix-list-current-id) guix-entries))
 217
 218 (defun guix-list-for-each-line (fun &rest args)
 219   "Call FUN with ARGS for each entry line."
 220   (or (derived-mode-p 'guix-list-mode)
 221       (error "The current buffer is not in Guix List mode"))
 222   (save-excursion
 223     (goto-char (point-min))
 224     (while (not (eobp))
 225       (apply fun args)
 226       (forward-line))))
 227
 228 (defun guix-list-fold-lines (fun init)
 229   "Fold over entry lines in the current list buffer.
 230 Call FUN with RESULT as argument for each line, using INIT as
 231 the initial value of RESULT.  Return the final result."
 232   (let ((res init))
 233     (guix-list-for-each-line
 234      (lambda () (setq res (funcall fun res))))
 235     res))
 236
 237 \f
 238 ;;; Marking and sorting
 239
 240 (defvar-local guix-list-marked nil
 241   "List of the marked entries.
 242 Each element of the list has a form:
 243
 244   (ID MARK-NAME . ARGS)
 245
 246 ID is an entry ID.
 247 MARK-NAME is a symbol from `guix-list-mark-alist'.
 248 ARGS is a list of additional values.")
 249
 250 (defvar guix-list-mark-alist
 251   '((empty   . ?\s)
 252     (general . ?*))
 253   "Alist of available mark names and mark characters.")
 254
 255 (defsubst guix-list-get-mark (name)
 256   "Return mark character by its NAME."
 257   (or (guix-get-key-val guix-list-mark-alist name)
 258       (error "Mark '%S' not found" name)))
 259
 260 (defsubst guix-list-get-mark-string (name)
 261   "Return mark string by its NAME."
 262   (string (guix-list-get-mark name)))
 263
 264 (defun guix-list-current-mark ()
 265   "Return mark character of the current line."
 266   (char-after (line-beginning-position)))
 267
 268 (defun guix-list-get-marked (&rest mark-names)
 269   "Return list of specs of entries marked with any mark from MARK-NAMES.
 270 Entry specs are elements from `guix-list-marked' list.
 271 If MARK-NAMES are not specified, use all marks from
 272 `guix-list-mark-alist' except the `empty' one."
 273   (or mark-names
 274       (setq mark-names
 275             (delq 'empty
 276                   (mapcar #'car guix-list-mark-alist))))
 277   (cl-remove-if-not (lambda (assoc)
 278                       (memq (cadr assoc) mark-names))
 279                     guix-list-marked))
 280
 281 (defun guix-list-get-marked-args (mark-name)
 282   "Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
 283 See `guix-list-marked' for the meaning of ARGS."
 284   (mapcar (lambda (spec)
 285             (let ((id (car spec))
 286                   (args (cddr spec)))
 287               (cons id args)))
 288           (guix-list-get-marked mark-name)))
 289
 290 (defun guix-list-get-marked-id-list (&rest mark-names)
 291   "Return list of IDs of entries marked with any mark from MARK-NAMES.
 292 See `guix-list-get-marked' for details."
 293   (mapcar #'car (apply #'guix-list-get-marked mark-names)))
 294
 295 (defun guix-list--mark (mark-name &optional advance &rest args)
 296   "Put a mark on the current line.
 297 Also add the current entry to `guix-list-marked' using its ID and ARGS.
 298 MARK-NAME is a symbol from `guix-list-mark-alist'.
 299 If ADVANCE is non-nil, move forward by one line after marking."
 300   (let ((id (guix-list-current-id)))
 301     (if (eq mark-name 'empty)
 302         (setq guix-list-marked (assq-delete-all id guix-list-marked))
 303       (let ((assoc (assq id guix-list-marked))
 304             (val (cons mark-name args)))
 305         (if assoc
 306             (setcdr assoc val)
 307           (push (cons id val) guix-list-marked)))))
 308   (tabulated-list-put-tag (guix-list-get-mark-string mark-name)
 309                           advance))
 310
 311 (defun guix-list-mark (&optional arg)
 312   "Mark the current line and move to the next line.
 313 With ARG, mark all lines."
 314   (interactive "P")
 315   (if arg
 316       (guix-list-mark-all)
 317     (guix-list--mark 'general t)))
 318
 319 (defun guix-list-mark-all (&optional mark-name)
 320   "Mark all lines with MARK-NAME mark.
 321 MARK-NAME is a symbol from `guix-list-mark-alist'.
 322 Interactively, put a general mark on all lines."
 323   (interactive)
 324   (or mark-name (setq mark-name 'general))
 325   (guix-list-for-each-line #'guix-list--mark mark-name))
 326
 327 (defun guix-list-unmark (&optional arg)
 328   "Unmark the current line and move to the next line.
 329 With ARG, unmark all lines."
 330   (interactive "P")
 331   (if arg
 332       (guix-list-unmark-all)
 333     (guix-list--mark 'empty t)))
 334
 335 (defun guix-list-unmark-backward ()
 336   "Move up one line and unmark it."
 337   (interactive)
 338   (forward-line -1)
 339   (guix-list--mark 'empty))
 340
 341 (defun guix-list-unmark-all ()
 342   "Unmark all lines."
 343   (interactive)
 344   (guix-list-mark-all 'empty))
 345
 346 (defun guix-list-restore-marks ()
 347   "Put marks according to `guix-list-mark-alist'."
 348   (guix-list-for-each-line
 349    (lambda ()
 350      (let ((mark-name (car (guix-get-key-val guix-list-marked
 351                                              (guix-list-current-id)))))
 352        (tabulated-list-put-tag
 353         (guix-list-get-mark-string (or mark-name 'empty)))))))
 354
 355 (defun guix-list-sort (&optional n)
 356   "Sort guix list entries by the column at point.
 357 With a numeric prefix argument N, sort the Nth column.
 358 Same as `tabulated-list-sort', but also restore marks after sorting."
 359   (interactive "P")
 360   (tabulated-list-sort n)
 361   (guix-list-restore-marks))
 362
 363 \f
 364 (defvar guix-list-mode-map
 365   (let ((map (make-sparse-keymap)))
 366     (set-keymap-parent map tabulated-list-mode-map)
 367     (define-key map (kbd "RET") 'guix-list-describe)
 368     (define-key map (kbd "m")   'guix-list-mark)
 369     (define-key map (kbd "*")   'guix-list-mark)
 370     (define-key map (kbd "u")   'guix-list-unmark)
 371     (define-key map (kbd "DEL") 'guix-list-unmark-backward)
 372     (define-key map [remap tabulated-list-sort] 'guix-list-sort)
 373     map)
 374   "Parent keymap for list buffers.")
 375
 376 (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
 377   "Parent mode for displaying information in list buffers."
 378   (setq tabulated-list-padding 2))
 379
 380 (defmacro guix-list-define-entry-type (entry-type &rest args)
 381   "Define common stuff for displaying ENTRY-TYPE entries in list buffers.
 382
 383 Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
 384 following keywords are available:
 385
 386   - `:sort-key' - default sort key for the tabulated list buffer.
 387
 388   - `:invert-sort' - if non-nil, invert initial sort.
 389
 390   - `:marks' - default value for the defined
 391     `guix-ENTRY-TYPE-mark-alist' variable.
 392
 393 This macro defines the following functions:
 394
 395   - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark
 396     specified in `:marks' argument."
 397   (let* ((entry-type-str (symbol-name entry-type))
 398          (prefix         (concat "guix-" entry-type-str "-list"))
 399          (mode-str       (concat prefix "-mode"))
 400          (init-fun       (intern (concat prefix "-mode-initialize")))
 401          (marks-var      (intern (concat prefix "-mark-alist")))
 402          (marks-val      nil)
 403          (sort-key       nil)
 404          (invert-sort    nil))
 405
 406     ;; Process the keyword args.
 407     (while (keywordp (car args))
 408       (pcase (pop args)
 409         (`:sort-key    (setq sort-key (pop args)))
 410         (`:invert-sort (setq invert-sort (pop args)))
 411         (`:marks       (setq marks-val (pop args)))
 412         (_ (pop args))))
 413
 414     `(progn
 415        (defvar ,marks-var ',marks-val
 416          ,(concat "Alist of additional marks for `" mode-str "'.\n"
 417                   "Marks from this list are added to `guix-list-mark-alist'."))
 418
 419        ,@(mapcar (lambda (mark-spec)
 420                    (let* ((mark-name (car mark-spec))
 421                           (mark-name-str (symbol-name mark-name)))
 422                      `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) ()
 423                         ,(concat "Put '" mark-name-str "' mark and move to the next line.\n"
 424                                  "Also add the current entry to `guix-list-marked'.")
 425                         (interactive)
 426                         (guix-list--mark ',mark-name t))))
 427                  marks-val)
 428
 429        (defun ,init-fun ()
 430          ,(concat "Initial settings for `" mode-str "'.")
 431          ,(when sort-key
 432             `(setq tabulated-list-sort-key
 433                    (guix-list-get-sort-key
 434                     ',entry-type ',sort-key ,invert-sort)))
 435          (setq tabulated-list-format
 436                (guix-list-get-list-format ',entry-type))
 437          (setq-local guix-list-mark-alist
 438                      (append guix-list-mark-alist ,marks-var))
 439          (tabulated-list-init-header)))))
 440
 441 (put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
 442
 443 (defun guix-list-describe-maybe (entry-type ids)
 444   "Describe ENTRY-TYPE entries in info buffer using list of IDS."
 445   (let ((count (length ids)))
 446     (when (or (<= count guix-list-describe-warning-count)
 447               (y-or-n-p (format "Do you really want to describe %d entries? "
 448                                 count)))
 449       (apply #'guix-get-show-entries
 450              guix-profile 'info entry-type 'id ids))))
 451
 452 (defun guix-list-describe (&optional arg)
 453   "Describe entries marked with a general mark.
 454 If no entries are marked, describe the current entry.
 455 With prefix (if ARG is non-nil), describe entries marked with any mark."
 456   (interactive "P")
 457   (let ((ids (or (apply #'guix-list-get-marked-id-list
 458                         (unless arg '(general)))
 459                  (list (guix-list-current-id)))))
 460     (guix-list-describe-maybe guix-entry-type ids)))
 461
 462 \f
 463 ;;; Displaying packages
 464
 465 (guix-define-buffer-type list package)
 466
 467 (guix-list-define-entry-type package
 468   :sort-key name
 469   :marks ((install . ?I)
 470           (upgrade . ?U)
 471           (delete  . ?D)))
 472
 473 (defface guix-package-list-installed
 474   '((t :inherit guix-package-info-installed-outputs))
 475   "Face used if there are installed outputs for the current package."
 476   :group 'guix-package-list)
 477
 478 (defface guix-package-list-obsolete
 479   '((t :inherit guix-package-info-obsolete))
 480   "Face used if a package is obsolete."
 481   :group 'guix-package-list)
 482
 483 (defcustom guix-package-list-generation-marking-enabled nil
 484   "If non-nil, allow putting marks in a list with 'generation packages'.
 485
 486 By default this is disabled, because it may be confusing.  For
 487 example a package is installed in some generation, so a user can
 488 mark it for deletion in the list of packages from this
 489 generation, but the package may not be installed in the latest
 490 generation, so actually it cannot be deleted.
 491
 492 If you managed to understand the explanation above or if you
 493 really know what you do or if you just don't care, you can set
 494 this variable to t.  It should not do much harm anyway (most
 495 likely)."
 496   :type 'boolean
 497   :group 'guix-package-list)
 498
 499 (let ((map guix-package-list-mode-map))
 500   (define-key map (kbd "x")   'guix-package-list-execute)
 501   (define-key map (kbd "i")   'guix-package-list-mark-install)
 502   (define-key map (kbd "d")   'guix-package-list-mark-delete)
 503   (define-key map (kbd "U")   'guix-package-list-mark-upgrade)
 504   (define-key map (kbd "^")   'guix-package-list-mark-upgrades))
 505
 506 (defun guix-package-list-get-name (name entry)
 507   "Return NAME of the package ENTRY.
 508 Colorize it with `guix-package-list-installed' or
 509 `guix-package-list-obsolete' if needed."
 510   (guix-get-string name
 511                    (cond ((guix-get-key-val entry 'obsolete)
 512                           'guix-package-list-obsolete)
 513                          ((guix-get-key-val entry 'installed)
 514                           'guix-package-list-installed))))
 515
 516 (defun guix-package-list-get-installed-outputs (installed &optional _)
 517   "Return string with outputs from INSTALLED entries."
 518   (guix-get-string
 519    (mapcar (lambda (entry)
 520              (guix-get-key-val entry 'output))
 521            installed)))
 522
 523 (defun guix-package-list-marking-check ()
 524   "Signal an error if marking is disabled for the current buffer."
 525   (when (and (not guix-package-list-generation-marking-enabled)
 526              (or (derived-mode-p 'guix-package-list-mode)
 527                  (derived-mode-p 'guix-output-list-mode))
 528              (eq guix-search-type 'generation))
 529     (error "Action marks are disabled for lists of 'generation packages'")))
 530
 531 (defun guix-package-list-mark-outputs (mark default
 532                                        &optional prompt available)
 533   "Mark the current package with MARK and move to the next line.
 534 If PROMPT is non-nil, use it to ask a user for outputs from
 535 AVAILABLE list, otherwise mark all DEFAULT outputs."
 536   (let ((outputs (if prompt
 537                      (guix-completing-read-multiple
 538                       prompt available nil t)
 539                    default)))
 540     (apply #'guix-list--mark mark t outputs)))
 541
 542 (defun guix-package-list-mark-install (&optional arg)
 543   "Mark the current package for installation and move to the next line.
 544 With ARG, prompt for the outputs to install (several outputs may
 545 be separated with \",\")."
 546   (interactive "P")
 547   (guix-package-list-marking-check)
 548   (let* ((entry     (guix-list-current-entry))
 549          (all       (guix-get-key-val entry 'outputs))
 550          (installed (guix-get-installed-outputs entry))
 551          (available (cl-set-difference all installed :test #'string=)))
 552     (or available
 553         (user-error "This package is already installed"))
 554     (guix-package-list-mark-outputs
 555      'install '("out")
 556      (and arg "Output(s) to install: ")
 557      available)))
 558
 559 (defun guix-package-list-mark-delete (&optional arg)
 560   "Mark the current package for deletion and move to the next line.
 561 With ARG, prompt for the outputs to delete (several outputs may
 562 be separated with \",\")."
 563   (interactive "P")
 564   (guix-package-list-marking-check)
 565   (let* ((entry (guix-list-current-entry))
 566          (installed (guix-get-installed-outputs entry)))
 567     (or installed
 568         (user-error "This package is not installed"))
 569     (guix-package-list-mark-outputs
 570      'delete installed
 571      (and arg "Output(s) to delete: ")
 572      installed)))
 573
 574 (defun guix-package-list-mark-upgrade (&optional arg)
 575   "Mark the current package for upgrading and move to the next line.
 576 With ARG, prompt for the outputs to upgrade (several outputs may
 577 be separated with \",\")."
 578   (interactive "P")
 579   (guix-package-list-marking-check)
 580   (let* ((entry (guix-list-current-entry))
 581          (installed (guix-get-installed-outputs entry)))
 582     (or installed
 583         (user-error "This package is not installed"))
 584     (when (or (guix-get-key-val entry 'obsolete)
 585               (y-or-n-p "This package is not obsolete.  Try to upgrade it anyway? "))
 586       (guix-package-list-mark-outputs
 587        'upgrade installed
 588        (and arg "Output(s) to upgrade: ")
 589        installed))))
 590
 591 (defun guix-list-mark-package-upgrades (fun)
 592   "Mark all obsolete packages for upgrading.
 593 Use FUN to perform marking of the current line.  FUN should
 594 accept an entry as argument."
 595   (guix-package-list-marking-check)
 596   (let ((obsolete (cl-remove-if-not
 597                    (lambda (entry)
 598                      (guix-get-key-val entry 'obsolete))
 599                    guix-entries)))
 600     (guix-list-for-each-line
 601      (lambda ()
 602        (let* ((id (guix-list-current-id))
 603               (entry (cl-find-if
 604                       (lambda (entry)
 605                         (equal id (guix-get-key-val entry 'id)))
 606                       obsolete)))
 607          (when entry
 608            (funcall fun entry)))))))
 609
 610 (defun guix-package-list-mark-upgrades ()
 611   "Mark all obsolete packages for upgrading."
 612   (interactive)
 613   (guix-list-mark-package-upgrades
 614    (lambda (entry)
 615      (apply #'guix-list--mark
 616             'upgrade nil
 617             (guix-get-installed-outputs entry)))))
 618
 619 (defun guix-list-execute-package-actions (fun)
 620   "Perform actions on the marked packages.
 621 Use FUN to define actions suitable for `guix-process-package-actions'.
 622 FUN should accept action-type as argument."
 623   (let ((actions (delq nil
 624                        (mapcar fun '(install delete upgrade)))))
 625     (if actions
 626         (guix-process-package-actions
 627          guix-profile actions (current-buffer))
 628       (user-error "No operations specified"))))
 629
 630 (defun guix-package-list-execute ()
 631   "Perform actions on the marked packages."
 632   (interactive)
 633   (guix-list-execute-package-actions #'guix-package-list-make-action))
 634
 635 (defun guix-package-list-make-action (action-type)
 636   "Return action specification for the packages marked with ACTION-TYPE.
 637 Return nil, if there are no packages marked with ACTION-TYPE.
 638 The specification is suitable for `guix-process-package-actions'."
 639   (let ((specs (guix-list-get-marked-args action-type)))
 640     (and specs (cons action-type specs))))
 641
 642 \f
 643 ;;; Displaying outputs
 644
 645 (guix-define-buffer-type list output
 646   :buffer-name "*Guix Package List*")
 647
 648 (guix-list-define-entry-type output
 649   :sort-key name
 650   :marks ((install . ?I)
 651           (upgrade . ?U)
 652           (delete  . ?D)))
 653
 654 (let ((map guix-output-list-mode-map))
 655   (define-key map (kbd "RET") 'guix-output-list-describe)
 656   (define-key map (kbd "x")   'guix-output-list-execute)
 657   (define-key map (kbd "i")   'guix-output-list-mark-install)
 658   (define-key map (kbd "d")   'guix-output-list-mark-delete)
 659   (define-key map (kbd "U")   'guix-output-list-mark-upgrade)
 660   (define-key map (kbd "^")   'guix-output-list-mark-upgrades))
 661
 662 (defun guix-output-list-mark-install ()
 663   "Mark the current output for installation and move to the next line."
 664   (interactive)
 665   (guix-package-list-marking-check)
 666   (let* ((entry     (guix-list-current-entry))
 667          (installed (guix-get-key-val entry 'installed)))
 668     (if installed
 669         (user-error "This output is already installed")
 670       (guix-list--mark 'install t))))
 671
 672 (defun guix-output-list-mark-delete ()
 673   "Mark the current output for deletion and move to the next line."
 674   (interactive)
 675   (guix-package-list-marking-check)
 676   (let* ((entry     (guix-list-current-entry))
 677          (installed (guix-get-key-val entry 'installed)))
 678     (if installed
 679         (guix-list--mark 'delete t)
 680       (user-error "This output is not installed"))))
 681
 682 (defun guix-output-list-mark-upgrade ()
 683   "Mark the current output for deletion and move to the next line."
 684   (interactive)
 685   (guix-package-list-marking-check)
 686   (let* ((entry     (guix-list-current-entry))
 687          (installed (guix-get-key-val entry 'installed)))
 688     (or installed
 689         (user-error "This output is not installed"))
 690     (when (or (guix-get-key-val entry 'obsolete)
 691               (y-or-n-p "This output is not obsolete.  Try to upgrade it anyway? "))
 692       (guix-list--mark 'upgrade t))))
 693
 694 (defun guix-output-list-mark-upgrades ()
 695   "Mark all obsolete package outputs for upgrading."
 696   (interactive)
 697   (guix-list-mark-package-upgrades
 698    (lambda (_) (guix-list--mark 'upgrade))))
 699
 700 (defun guix-output-list-execute ()
 701   "Perform actions on the marked outputs."
 702   (interactive)
 703   (guix-list-execute-package-actions #'guix-output-list-make-action))
 704
 705 (defun guix-output-list-make-action (action-type)
 706   "Return action specification for the outputs marked with ACTION-TYPE.
 707 Return nil, if there are no outputs marked with ACTION-TYPE.
 708 The specification is suitable for `guix-process-output-actions'."
 709   (let ((ids (guix-list-get-marked-id-list action-type)))
 710     (and ids (cons action-type
 711                    (mapcar #'guix-get-package-id-and-output-by-output-id
 712                            ids)))))
 713
 714 (defun guix-output-list-describe (&optional arg)
 715   "Describe outputs or packages marked with a general mark.
 716 If no entries are marked, describe the current output or package.
 717 With prefix (if ARG is non-nil), describe entries marked with any mark.
 718 Also see `guix-package-info-type'."
 719   (interactive "P")
 720   (if (eq guix-package-info-type 'output)
 721       (guix-list-describe arg)
 722     (let* ((oids (or (apply #'guix-list-get-marked-id-list
 723                             (unless arg '(general)))
 724                      (list (guix-list-current-id))))
 725            (pids (mapcar (lambda (oid)
 726                            (car (guix-get-package-id-and-output-by-output-id
 727                                  oid)))
 728                          oids)))
 729       (guix-list-describe-maybe 'package (cl-remove-duplicates pids)))))
 730
 731 \f
 732 ;;; Displaying generations
 733
 734 (guix-define-buffer-type list generation)
 735
 736 (guix-list-define-entry-type generation
 737   :sort-key number
 738   :invert-sort t
 739   :marks ((delete . ?D)))
 740
 741 (let ((map guix-generation-list-mode-map))
 742   (define-key map (kbd "RET") 'guix-generation-list-show-packages)
 743   (define-key map (kbd "+")   'guix-generation-list-show-added-packages)
 744   (define-key map (kbd "-")   'guix-generation-list-show-removed-packages)
 745   (define-key map (kbd "=")   'guix-generation-list-diff)
 746   (define-key map (kbd "D")   'guix-generation-list-diff)
 747   (define-key map (kbd "e")   'guix-generation-list-ediff)
 748   (define-key map (kbd "x")   'guix-generation-list-execute)
 749   (define-key map (kbd "i")   'guix-list-describe)
 750   (define-key map (kbd "s")   'guix-generation-list-switch)
 751   (define-key map (kbd "d")   'guix-generation-list-mark-delete))
 752
 753 (defun guix-generation-list-get-current (val &optional _)
 754   "Return string from VAL showing whether this generation is current.
 755 VAL is a boolean value."
 756   (if val "(current)" ""))
 757
 758 (defun guix-generation-list-switch ()
 759   "Switch current profile to the generation at point."
 760   (interactive)
 761   (let* ((entry   (guix-list-current-entry))
 762          (current (guix-get-key-val entry 'current))
 763          (number  (guix-get-key-val entry 'number)))
 764     (if current
 765         (user-error "This generation is already the current one")
 766       (guix-switch-to-generation guix-profile number (current-buffer)))))
 767
 768 (defun guix-generation-list-show-packages ()
 769   "List installed packages for the generation at point."
 770   (interactive)
 771   (guix-get-show-entries guix-profile 'list guix-package-list-type
 772                          'generation (guix-list-current-id)))
 773
 774 (defun guix-generation-list-generations-to-compare ()
 775   "Return a sorted list of 2 marked generations for comparing."
 776   (let ((numbers (guix-list-get-marked-id-list 'general)))
 777     (if (/= (length numbers) 2)
 778         (user-error "2 generations should be marked for comparing")
 779       (sort numbers #'<))))
 780
 781 (defun guix-generation-list-show-added-packages ()
 782   "List package outputs added to the latest marked generation.
 783 If 2 generations are marked with \\[guix-list-mark], display
 784 outputs installed in the latest marked generation that were not
 785 installed in the other one."
 786   (interactive)
 787   (apply #'guix-get-show-entries
 788          guix-profile 'list 'output 'generation-diff
 789          (reverse (guix-generation-list-generations-to-compare))))
 790
 791 (defun guix-generation-list-show-removed-packages ()
 792   "List package outputs removed from the latest marked generation.
 793 If 2 generations are marked with \\[guix-list-mark], display
 794 outputs not installed in the latest marked generation that were
 795 installed in the other one."
 796   (interactive)
 797   (apply #'guix-get-show-entries
 798          guix-profile 'list 'output 'generation-diff
 799          (guix-generation-list-generations-to-compare)))
 800
 801 (defun guix-generation-list-compare (diff-fun gen-fun)
 802   "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results."
 803   (cl-multiple-value-bind (gen1 gen2)
 804       (guix-generation-list-generations-to-compare)
 805     (funcall diff-fun
 806              (funcall gen-fun gen1)
 807              (funcall gen-fun gen2))))
 808
 809 (defun guix-generation-list-ediff-manifests ()
 810   "Run Ediff on manifests of the 2 marked generations."
 811   (interactive)
 812   (guix-generation-list-compare
 813    #'ediff-files
 814    #'guix-profile-generation-manifest-file))
 815
 816 (defun guix-generation-list-diff-manifests ()
 817   "Run Diff on manifests of the 2 marked generations."
 818   (interactive)
 819   (guix-generation-list-compare
 820    #'guix-diff
 821    #'guix-profile-generation-manifest-file))
 822
 823 (defun guix-generation-list-ediff-packages ()
 824   "Run Ediff on package outputs installed in the 2 marked generations."
 825   (interactive)
 826   (guix-generation-list-compare
 827    #'ediff-buffers
 828    #'guix-profile-generation-packages-buffer))
 829
 830 (defun guix-generation-list-diff-packages ()
 831   "Run Diff on package outputs installed in the 2 marked generations."
 832   (interactive)
 833   (guix-generation-list-compare
 834    #'guix-diff
 835    #'guix-profile-generation-packages-buffer))
 836
 837 (defun guix-generation-list-ediff (arg)
 838   "Run Ediff on package outputs installed in the 2 marked generations.
 839 With ARG, run Ediff on manifests of the marked generations."
 840   (interactive "P")
 841   (if arg
 842       (guix-generation-list-ediff-manifests)
 843     (guix-generation-list-ediff-packages)))
 844
 845 (defun guix-generation-list-diff (arg)
 846   "Run Diff on package outputs installed in the 2 marked generations.
 847 With ARG, run Diff on manifests of the marked generations."
 848   (interactive "P")
 849   (if arg
 850       (guix-generation-list-diff-manifests)
 851     (guix-generation-list-diff-packages)))
 852
 853 (defun guix-generation-list-mark-delete (&optional arg)
 854   "Mark the current generation for deletion and move to the next line.
 855 With ARG, mark all generations for deletion."
 856   (interactive "P")
 857   (if arg
 858       (guix-list-mark-all 'delete)
 859     (guix-list--mark 'delete t)))
 860
 861 (defun guix-generation-list-execute ()
 862   "Delete marked generations."
 863   (interactive)
 864   (let ((marked (guix-list-get-marked-id-list 'delete)))
 865     (or marked
 866         (user-error "No generations marked for deletion"))
 867     (guix-delete-generations guix-profile marked (current-buffer))))
 868
 869 (provide 'guix-list)
 870
 871 ;;; guix-list.el ends here