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-current-package-id ()
 219   "Return ID of the current package."
 220   (cl-ecase major-mode
 221     (guix-package-list-mode
 222      (guix-list-current-id))
 223     (guix-output-list-mode
 224      (guix-get-key-val (guix-list-current-entry) 'package-id))))
 225
 226 (defun guix-list-for-each-line (fun &rest args)
 227   "Call FUN with ARGS for each entry line."
 228   (or (derived-mode-p 'guix-list-mode)
 229       (error "The current buffer is not in Guix List mode"))
 230   (save-excursion
 231     (goto-char (point-min))
 232     (while (not (eobp))
 233       (apply fun args)
 234       (forward-line))))
 235
 236 (defun guix-list-fold-lines (fun init)
 237   "Fold over entry lines in the current list buffer.
 238 Call FUN with RESULT as argument for each line, using INIT as
 239 the initial value of RESULT.  Return the final result."
 240   (let ((res init))
 241     (guix-list-for-each-line
 242      (lambda () (setq res (funcall fun res))))
 243     res))
 244
 245 \f
 246 ;;; Marking and sorting
 247
 248 (defvar-local guix-list-marked nil
 249   "List of the marked entries.
 250 Each element of the list has a form:
 251
 252   (ID MARK-NAME . ARGS)
 253
 254 ID is an entry ID.
 255 MARK-NAME is a symbol from `guix-list-mark-alist'.
 256 ARGS is a list of additional values.")
 257
 258 (defvar guix-list-mark-alist
 259   '((empty   . ?\s)
 260     (general . ?*))
 261   "Alist of available mark names and mark characters.")
 262
 263 (defsubst guix-list-get-mark (name)
 264   "Return mark character by its NAME."
 265   (or (guix-get-key-val guix-list-mark-alist name)
 266       (error "Mark '%S' not found" name)))
 267
 268 (defsubst guix-list-get-mark-string (name)
 269   "Return mark string by its NAME."
 270   (string (guix-list-get-mark name)))
 271
 272 (defun guix-list-current-mark ()
 273   "Return mark character of the current line."
 274   (char-after (line-beginning-position)))
 275
 276 (defun guix-list-get-marked (&rest mark-names)
 277   "Return list of specs of entries marked with any mark from MARK-NAMES.
 278 Entry specs are elements from `guix-list-marked' list.
 279 If MARK-NAMES are not specified, use all marks from
 280 `guix-list-mark-alist' except the `empty' one."
 281   (or mark-names
 282       (setq mark-names
 283             (delq 'empty
 284                   (mapcar #'car guix-list-mark-alist))))
 285   (cl-remove-if-not (lambda (assoc)
 286                       (memq (cadr assoc) mark-names))
 287                     guix-list-marked))
 288
 289 (defun guix-list-get-marked-args (mark-name)
 290   "Return list of (ID . ARGS) elements from lines marked with MARK-NAME.
 291 See `guix-list-marked' for the meaning of ARGS."
 292   (mapcar (lambda (spec)
 293             (let ((id (car spec))
 294                   (args (cddr spec)))
 295               (cons id args)))
 296           (guix-list-get-marked mark-name)))
 297
 298 (defun guix-list-get-marked-id-list (&rest mark-names)
 299   "Return list of IDs of entries marked with any mark from MARK-NAMES.
 300 See `guix-list-get-marked' for details."
 301   (mapcar #'car (apply #'guix-list-get-marked mark-names)))
 302
 303 (defun guix-list--mark (mark-name &optional advance &rest args)
 304   "Put a mark on the current line.
 305 Also add the current entry to `guix-list-marked' using its ID and ARGS.
 306 MARK-NAME is a symbol from `guix-list-mark-alist'.
 307 If ADVANCE is non-nil, move forward by one line after marking."
 308   (let ((id (guix-list-current-id)))
 309     (if (eq mark-name 'empty)
 310         (setq guix-list-marked (assq-delete-all id guix-list-marked))
 311       (let ((assoc (assq id guix-list-marked))
 312             (val (cons mark-name args)))
 313         (if assoc
 314             (setcdr assoc val)
 315           (push (cons id val) guix-list-marked)))))
 316   (tabulated-list-put-tag (guix-list-get-mark-string mark-name)
 317                           advance))
 318
 319 (defun guix-list-mark (&optional arg)
 320   "Mark the current line and move to the next line.
 321 With ARG, mark all lines."
 322   (interactive "P")
 323   (if arg
 324       (guix-list-mark-all)
 325     (guix-list--mark 'general t)))
 326
 327 (defun guix-list-mark-all (&optional mark-name)
 328   "Mark all lines with MARK-NAME mark.
 329 MARK-NAME is a symbol from `guix-list-mark-alist'.
 330 Interactively, put a general mark on all lines."
 331   (interactive)
 332   (or mark-name (setq mark-name 'general))
 333   (guix-list-for-each-line #'guix-list--mark mark-name))
 334
 335 (defun guix-list-unmark (&optional arg)
 336   "Unmark the current line and move to the next line.
 337 With ARG, unmark all lines."
 338   (interactive "P")
 339   (if arg
 340       (guix-list-unmark-all)
 341     (guix-list--mark 'empty t)))
 342
 343 (defun guix-list-unmark-backward ()
 344   "Move up one line and unmark it."
 345   (interactive)
 346   (forward-line -1)
 347   (guix-list--mark 'empty))
 348
 349 (defun guix-list-unmark-all ()
 350   "Unmark all lines."
 351   (interactive)
 352   (guix-list-mark-all 'empty))
 353
 354 (defun guix-list-restore-marks ()
 355   "Put marks according to `guix-list-mark-alist'."
 356   (guix-list-for-each-line
 357    (lambda ()
 358      (let ((mark-name (car (guix-get-key-val guix-list-marked
 359                                              (guix-list-current-id)))))
 360        (tabulated-list-put-tag
 361         (guix-list-get-mark-string (or mark-name 'empty)))))))
 362
 363 (defun guix-list-sort (&optional n)
 364   "Sort guix list entries by the column at point.
 365 With a numeric prefix argument N, sort the Nth column.
 366 Same as `tabulated-list-sort', but also restore marks after sorting."
 367   (interactive "P")
 368   (tabulated-list-sort n)
 369   (guix-list-restore-marks))
 370
 371 \f
 372 (defvar guix-list-mode-map
 373   (let ((map (make-sparse-keymap)))
 374     (set-keymap-parent
 375      map (make-composed-keymap guix-root-map
 376                                tabulated-list-mode-map))
 377     (define-key map (kbd "RET") 'guix-list-describe)
 378     (define-key map (kbd "m")   'guix-list-mark)
 379     (define-key map (kbd "*")   'guix-list-mark)
 380     (define-key map (kbd "u")   'guix-list-unmark)
 381     (define-key map (kbd "DEL") 'guix-list-unmark-backward)
 382     (define-key map [remap tabulated-list-sort] 'guix-list-sort)
 383     map)
 384   "Parent keymap for list buffers.")
 385
 386 (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List"
 387   "Parent mode for displaying information in list buffers."
 388   (setq tabulated-list-padding 2))
 389
 390 (defmacro guix-list-define-entry-type (entry-type &rest args)
 391   "Define common stuff for displaying ENTRY-TYPE entries in list buffers.
 392
 393 Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
 394 following keywords are available:
 395
 396   - `:sort-key' - default sort key for the tabulated list buffer.
 397
 398   - `:invert-sort' - if non-nil, invert initial sort.
 399
 400   - `:marks' - default value for the defined
 401     `guix-ENTRY-TYPE-mark-alist' variable.
 402
 403 This macro defines the following functions:
 404
 405   - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark
 406     specified in `:marks' argument."
 407   (let* ((entry-type-str (symbol-name entry-type))
 408          (prefix         (concat "guix-" entry-type-str "-list"))
 409          (mode-str       (concat prefix "-mode"))
 410          (init-fun       (intern (concat prefix "-mode-initialize")))
 411          (marks-var      (intern (concat prefix "-mark-alist")))
 412          (marks-val      nil)
 413          (sort-key       nil)
 414          (invert-sort    nil))
 415
 416     ;; Process the keyword args.
 417     (while (keywordp (car args))
 418       (pcase (pop args)
 419         (`:sort-key    (setq sort-key (pop args)))
 420         (`:invert-sort (setq invert-sort (pop args)))
 421         (`:marks       (setq marks-val (pop args)))
 422         (_ (pop args))))
 423
 424     `(progn
 425        (defvar ,marks-var ',marks-val
 426          ,(concat "Alist of additional marks for `" mode-str "'.\n"
 427                   "Marks from this list are added to `guix-list-mark-alist'."))
 428
 429        ,@(mapcar (lambda (mark-spec)
 430                    (let* ((mark-name (car mark-spec))
 431                           (mark-name-str (symbol-name mark-name)))
 432                      `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) ()
 433                         ,(concat "Put '" mark-name-str "' mark and move to the next line.\n"
 434                                  "Also add the current entry to `guix-list-marked'.")
 435                         (interactive)
 436                         (guix-list--mark ',mark-name t))))
 437                  marks-val)
 438
 439        (defun ,init-fun ()
 440          ,(concat "Initial settings for `" mode-str "'.")
 441          ,(when sort-key
 442             `(setq tabulated-list-sort-key
 443                    (guix-list-get-sort-key
 444                     ',entry-type ',sort-key ,invert-sort)))
 445          (setq tabulated-list-format
 446                (guix-list-get-list-format ',entry-type))
 447          (setq-local guix-list-mark-alist
 448                      (append guix-list-mark-alist ,marks-var))
 449          (tabulated-list-init-header)))))
 450
 451 (put 'guix-list-define-entry-type 'lisp-indent-function 'defun)
 452
 453 (defun guix-list-describe-maybe (entry-type ids)
 454   "Describe ENTRY-TYPE entries in info buffer using list of IDS."
 455   (let ((count (length ids)))
 456     (when (or (<= count guix-list-describe-warning-count)
 457               (y-or-n-p (format "Do you really want to describe %d entries? "
 458                                 count)))
 459       (apply #'guix-get-show-entries
 460              guix-profile 'info entry-type 'id ids))))
 461
 462 (defun guix-list-describe (&optional arg)
 463   "Describe entries marked with a general mark.
 464 If no entries are marked, describe the current entry.
 465 With prefix (if ARG is non-nil), describe entries marked with any mark."
 466   (interactive "P")
 467   (let ((ids (or (apply #'guix-list-get-marked-id-list
 468                         (unless arg '(general)))
 469                  (list (guix-list-current-id)))))
 470     (guix-list-describe-maybe guix-entry-type ids)))
 471
 472 (defun guix-list-edit-package ()
 473   "Go to the location of the current package."
 474   (interactive)
 475   (guix-edit-package (guix-list-current-package-id)))
 476
 477 \f
 478 ;;; Displaying packages
 479
 480 (guix-define-buffer-type list package)
 481
 482 (guix-list-define-entry-type package
 483   :sort-key name
 484   :marks ((install . ?I)
 485           (upgrade . ?U)
 486           (delete  . ?D)))
 487
 488 (defface guix-package-list-installed
 489   '((t :inherit guix-package-info-installed-outputs))
 490   "Face used if there are installed outputs for the current package."
 491   :group 'guix-package-list)
 492
 493 (defface guix-package-list-obsolete
 494   '((t :inherit guix-package-info-obsolete))
 495   "Face used if a package is obsolete."
 496   :group 'guix-package-list)
 497
 498 (defcustom guix-package-list-generation-marking-enabled nil
 499   "If non-nil, allow putting marks in a list with 'generation packages'.
 500
 501 By default this is disabled, because it may be confusing.  For
 502 example a package is installed in some generation, so a user can
 503 mark it for deletion in the list of packages from this
 504 generation, but the package may not be installed in the latest
 505 generation, so actually it cannot be deleted.
 506
 507 If you managed to understand the explanation above or if you
 508 really know what you do or if you just don't care, you can set
 509 this variable to t.  It should not do much harm anyway (most
 510 likely)."
 511   :type 'boolean
 512   :group 'guix-package-list)
 513
 514 (let ((map guix-package-list-mode-map))
 515   (define-key map (kbd "e")   'guix-list-edit-package)
 516   (define-key map (kbd "x")   'guix-package-list-execute)
 517   (define-key map (kbd "i")   'guix-package-list-mark-install)
 518   (define-key map (kbd "d")   'guix-package-list-mark-delete)
 519   (define-key map (kbd "U")   'guix-package-list-mark-upgrade)
 520   (define-key map (kbd "^")   'guix-package-list-mark-upgrades))
 521
 522 (defun guix-package-list-get-name (name entry)
 523   "Return NAME of the package ENTRY.
 524 Colorize it with `guix-package-list-installed' or
 525 `guix-package-list-obsolete' if needed."
 526   (guix-get-string name
 527                    (cond ((guix-get-key-val entry 'obsolete)
 528                           'guix-package-list-obsolete)
 529                          ((guix-get-key-val entry 'installed)
 530                           'guix-package-list-installed))))
 531
 532 (defun guix-package-list-get-installed-outputs (installed &optional _)
 533   "Return string with outputs from INSTALLED entries."
 534   (guix-get-string
 535    (mapcar (lambda (entry)
 536              (guix-get-key-val entry 'output))
 537            installed)))
 538
 539 (defun guix-package-list-marking-check ()
 540   "Signal an error if marking is disabled for the current buffer."
 541   (when (and (not guix-package-list-generation-marking-enabled)
 542              (or (derived-mode-p 'guix-package-list-mode)
 543                  (derived-mode-p 'guix-output-list-mode))
 544              (eq guix-search-type 'generation))
 545     (error "Action marks are disabled for lists of 'generation packages'")))
 546
 547 (defun guix-package-list-mark-outputs (mark default
 548                                        &optional prompt available)
 549   "Mark the current package with MARK and move to the next line.
 550 If PROMPT is non-nil, use it to ask a user for outputs from
 551 AVAILABLE list, otherwise mark all DEFAULT outputs."
 552   (let ((outputs (if prompt
 553                      (guix-completing-read-multiple
 554                       prompt available nil t)
 555                    default)))
 556     (apply #'guix-list--mark mark t outputs)))
 557
 558 (defun guix-package-list-mark-install (&optional arg)
 559   "Mark the current package for installation and move to the next line.
 560 With ARG, prompt for the outputs to install (several outputs may
 561 be separated with \",\")."
 562   (interactive "P")
 563   (guix-package-list-marking-check)
 564   (let* ((entry     (guix-list-current-entry))
 565          (all       (guix-get-key-val entry 'outputs))
 566          (installed (guix-get-installed-outputs entry))
 567          (available (cl-set-difference all installed :test #'string=)))
 568     (or available
 569         (user-error "This package is already installed"))
 570     (guix-package-list-mark-outputs
 571      'install '("out")
 572      (and arg "Output(s) to install: ")
 573      available)))
 574
 575 (defun guix-package-list-mark-delete (&optional arg)
 576   "Mark the current package for deletion and move to the next line.
 577 With ARG, prompt for the outputs to delete (several outputs may
 578 be separated with \",\")."
 579   (interactive "P")
 580   (guix-package-list-marking-check)
 581   (let* ((entry (guix-list-current-entry))
 582          (installed (guix-get-installed-outputs entry)))
 583     (or installed
 584         (user-error "This package is not installed"))
 585     (guix-package-list-mark-outputs
 586      'delete installed
 587      (and arg "Output(s) to delete: ")
 588      installed)))
 589
 590 (defun guix-package-list-mark-upgrade (&optional arg)
 591   "Mark the current package for upgrading and move to the next line.
 592 With ARG, prompt for the outputs to upgrade (several outputs may
 593 be separated with \",\")."
 594   (interactive "P")
 595   (guix-package-list-marking-check)
 596   (let* ((entry (guix-list-current-entry))
 597          (installed (guix-get-installed-outputs entry)))
 598     (or installed
 599         (user-error "This package is not installed"))
 600     (when (or (guix-get-key-val entry 'obsolete)
 601               (y-or-n-p "This package is not obsolete.  Try to upgrade it anyway? "))
 602       (guix-package-list-mark-outputs
 603        'upgrade installed
 604        (and arg "Output(s) to upgrade: ")
 605        installed))))
 606
 607 (defun guix-list-mark-package-upgrades (fun)
 608   "Mark all obsolete packages for upgrading.
 609 Use FUN to perform marking of the current line.  FUN should
 610 accept an entry as argument."
 611   (guix-package-list-marking-check)
 612   (let ((obsolete (cl-remove-if-not
 613                    (lambda (entry)
 614                      (guix-get-key-val entry 'obsolete))
 615                    guix-entries)))
 616     (guix-list-for-each-line
 617      (lambda ()
 618        (let* ((id (guix-list-current-id))
 619               (entry (cl-find-if
 620                       (lambda (entry)
 621                         (equal id (guix-get-key-val entry 'id)))
 622                       obsolete)))
 623          (when entry
 624            (funcall fun entry)))))))
 625
 626 (defun guix-package-list-mark-upgrades ()
 627   "Mark all obsolete packages for upgrading."
 628   (interactive)
 629   (guix-list-mark-package-upgrades
 630    (lambda (entry)
 631      (apply #'guix-list--mark
 632             'upgrade nil
 633             (guix-get-installed-outputs entry)))))
 634
 635 (defun guix-list-execute-package-actions (fun)
 636   "Perform actions on the marked packages.
 637 Use FUN to define actions suitable for `guix-process-package-actions'.
 638 FUN should accept action-type as argument."
 639   (let ((actions (delq nil
 640                        (mapcar fun '(install delete upgrade)))))
 641     (if actions
 642         (guix-process-package-actions
 643          guix-profile actions (current-buffer))
 644       (user-error "No operations specified"))))
 645
 646 (defun guix-package-list-execute ()
 647   "Perform actions on the marked packages."
 648   (interactive)
 649   (guix-list-execute-package-actions #'guix-package-list-make-action))
 650
 651 (defun guix-package-list-make-action (action-type)
 652   "Return action specification for the packages marked with ACTION-TYPE.
 653 Return nil, if there are no packages marked with ACTION-TYPE.
 654 The specification is suitable for `guix-process-package-actions'."
 655   (let ((specs (guix-list-get-marked-args action-type)))
 656     (and specs (cons action-type specs))))
 657
 658 \f
 659 ;;; Displaying outputs
 660
 661 (guix-define-buffer-type list output
 662   :buffer-name "*Guix Package List*"
 663   :required (package-id))
 664
 665 (guix-list-define-entry-type output
 666   :sort-key name
 667   :marks ((install . ?I)
 668           (upgrade . ?U)
 669           (delete  . ?D)))
 670
 671 (let ((map guix-output-list-mode-map))
 672   (define-key map (kbd "RET") 'guix-output-list-describe)
 673   (define-key map (kbd "e")   'guix-list-edit-package)
 674   (define-key map (kbd "x")   'guix-output-list-execute)
 675   (define-key map (kbd "i")   'guix-output-list-mark-install)
 676   (define-key map (kbd "d")   'guix-output-list-mark-delete)
 677   (define-key map (kbd "U")   'guix-output-list-mark-upgrade)
 678   (define-key map (kbd "^")   'guix-output-list-mark-upgrades))
 679
 680 (defun guix-output-list-mark-install ()
 681   "Mark the current output for installation and move to the next line."
 682   (interactive)
 683   (guix-package-list-marking-check)
 684   (let* ((entry     (guix-list-current-entry))
 685          (installed (guix-get-key-val entry 'installed)))
 686     (if installed
 687         (user-error "This output is already installed")
 688       (guix-list--mark 'install t))))
 689
 690 (defun guix-output-list-mark-delete ()
 691   "Mark the current output for deletion and move to the next line."
 692   (interactive)
 693   (guix-package-list-marking-check)
 694   (let* ((entry     (guix-list-current-entry))
 695          (installed (guix-get-key-val entry 'installed)))
 696     (if installed
 697         (guix-list--mark 'delete t)
 698       (user-error "This output is not installed"))))
 699
 700 (defun guix-output-list-mark-upgrade ()
 701   "Mark the current output for deletion and move to the next line."
 702   (interactive)
 703   (guix-package-list-marking-check)
 704   (let* ((entry     (guix-list-current-entry))
 705          (installed (guix-get-key-val entry 'installed)))
 706     (or installed
 707         (user-error "This output is not installed"))
 708     (when (or (guix-get-key-val entry 'obsolete)
 709               (y-or-n-p "This output is not obsolete.  Try to upgrade it anyway? "))
 710       (guix-list--mark 'upgrade t))))
 711
 712 (defun guix-output-list-mark-upgrades ()
 713   "Mark all obsolete package outputs for upgrading."
 714   (interactive)
 715   (guix-list-mark-package-upgrades
 716    (lambda (_) (guix-list--mark 'upgrade))))
 717
 718 (defun guix-output-list-execute ()
 719   "Perform actions on the marked outputs."
 720   (interactive)
 721   (guix-list-execute-package-actions #'guix-output-list-make-action))
 722
 723 (defun guix-output-list-make-action (action-type)
 724   "Return action specification for the outputs marked with ACTION-TYPE.
 725 Return nil, if there are no outputs marked with ACTION-TYPE.
 726 The specification is suitable for `guix-process-output-actions'."
 727   (let ((ids (guix-list-get-marked-id-list action-type)))
 728     (and ids (cons action-type
 729                    (mapcar #'guix-get-package-id-and-output-by-output-id
 730                            ids)))))
 731
 732 (defun guix-output-list-describe (&optional arg)
 733   "Describe outputs or packages marked with a general mark.
 734 If no entries are marked, describe the current output or package.
 735 With prefix (if ARG is non-nil), describe entries marked with any mark.
 736 Also see `guix-package-info-type'."
 737   (interactive "P")
 738   (if (eq guix-package-info-type 'output)
 739       (guix-list-describe arg)
 740     (let* ((oids (or (apply #'guix-list-get-marked-id-list
 741                             (unless arg '(general)))
 742                      (list (guix-list-current-id))))
 743            (pids (mapcar (lambda (oid)
 744                            (car (guix-get-package-id-and-output-by-output-id
 745                                  oid)))
 746                          oids)))
 747       (guix-list-describe-maybe 'package (cl-remove-duplicates pids)))))
 748
 749 \f
 750 ;;; Displaying generations
 751
 752 (guix-define-buffer-type list generation)
 753
 754 (guix-list-define-entry-type generation
 755   :sort-key number
 756   :invert-sort t
 757   :marks ((delete . ?D)))
 758
 759 (let ((map guix-generation-list-mode-map))
 760   (define-key map (kbd "RET") 'guix-generation-list-show-packages)
 761   (define-key map (kbd "+")   'guix-generation-list-show-added-packages)
 762   (define-key map (kbd "-")   'guix-generation-list-show-removed-packages)
 763   (define-key map (kbd "=")   'guix-generation-list-diff)
 764   (define-key map (kbd "D")   'guix-generation-list-diff)
 765   (define-key map (kbd "e")   'guix-generation-list-ediff)
 766   (define-key map (kbd "x")   'guix-generation-list-execute)
 767   (define-key map (kbd "i")   'guix-list-describe)
 768   (define-key map (kbd "s")   'guix-generation-list-switch)
 769   (define-key map (kbd "d")   'guix-generation-list-mark-delete))
 770
 771 (defun guix-generation-list-get-current (val &optional _)
 772   "Return string from VAL showing whether this generation is current.
 773 VAL is a boolean value."
 774   (if val "(current)" ""))
 775
 776 (defun guix-generation-list-switch ()
 777   "Switch current profile to the generation at point."
 778   (interactive)
 779   (let* ((entry   (guix-list-current-entry))
 780          (current (guix-get-key-val entry 'current))
 781          (number  (guix-get-key-val entry 'number)))
 782     (if current
 783         (user-error "This generation is already the current one")
 784       (guix-switch-to-generation guix-profile number (current-buffer)))))
 785
 786 (defun guix-generation-list-show-packages ()
 787   "List installed packages for the generation at point."
 788   (interactive)
 789   (guix-get-show-entries guix-profile 'list guix-package-list-type
 790                          'generation (guix-list-current-id)))
 791
 792 (defun guix-generation-list-generations-to-compare ()
 793   "Return a sorted list of 2 marked generations for comparing."
 794   (let ((numbers (guix-list-get-marked-id-list 'general)))
 795     (if (/= (length numbers) 2)
 796         (user-error "2 generations should be marked for comparing")
 797       (sort numbers #'<))))
 798
 799 (defun guix-generation-list-show-added-packages ()
 800   "List package outputs added to the latest marked generation.
 801 If 2 generations are marked with \\[guix-list-mark], display
 802 outputs installed in the latest marked generation that were not
 803 installed in the other one."
 804   (interactive)
 805   (apply #'guix-get-show-entries
 806          guix-profile 'list 'output 'generation-diff
 807          (reverse (guix-generation-list-generations-to-compare))))
 808
 809 (defun guix-generation-list-show-removed-packages ()
 810   "List package outputs removed from the latest marked generation.
 811 If 2 generations are marked with \\[guix-list-mark], display
 812 outputs not installed in the latest marked generation that were
 813 installed in the other one."
 814   (interactive)
 815   (apply #'guix-get-show-entries
 816          guix-profile 'list 'output 'generation-diff
 817          (guix-generation-list-generations-to-compare)))
 818
 819 (defun guix-generation-list-compare (diff-fun gen-fun)
 820   "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results."
 821   (cl-multiple-value-bind (gen1 gen2)
 822       (guix-generation-list-generations-to-compare)
 823     (funcall diff-fun
 824              (funcall gen-fun gen1)
 825              (funcall gen-fun gen2))))
 826
 827 (defun guix-generation-list-ediff-manifests ()
 828   "Run Ediff on manifests of the 2 marked generations."
 829   (interactive)
 830   (guix-generation-list-compare
 831    #'ediff-files
 832    #'guix-profile-generation-manifest-file))
 833
 834 (defun guix-generation-list-diff-manifests ()
 835   "Run Diff on manifests of the 2 marked generations."
 836   (interactive)
 837   (guix-generation-list-compare
 838    #'guix-diff
 839    #'guix-profile-generation-manifest-file))
 840
 841 (defun guix-generation-list-ediff-packages ()
 842   "Run Ediff on package outputs installed in the 2 marked generations."
 843   (interactive)
 844   (guix-generation-list-compare
 845    #'ediff-buffers
 846    #'guix-profile-generation-packages-buffer))
 847
 848 (defun guix-generation-list-diff-packages ()
 849   "Run Diff on package outputs installed in the 2 marked generations."
 850   (interactive)
 851   (guix-generation-list-compare
 852    #'guix-diff
 853    #'guix-profile-generation-packages-buffer))
 854
 855 (defun guix-generation-list-ediff (arg)
 856   "Run Ediff on package outputs installed in the 2 marked generations.
 857 With ARG, run Ediff on manifests of the marked generations."
 858   (interactive "P")
 859   (if arg
 860       (guix-generation-list-ediff-manifests)
 861     (guix-generation-list-ediff-packages)))
 862
 863 (defun guix-generation-list-diff (arg)
 864   "Run Diff on package outputs installed in the 2 marked generations.
 865 With ARG, run Diff on manifests of the marked generations."
 866   (interactive "P")
 867   (if arg
 868       (guix-generation-list-diff-manifests)
 869     (guix-generation-list-diff-packages)))
 870
 871 (defun guix-generation-list-mark-delete (&optional arg)
 872   "Mark the current generation for deletion and move to the next line.
 873 With ARG, mark all generations for deletion."
 874   (interactive "P")
 875   (if arg
 876       (guix-list-mark-all 'delete)
 877     (guix-list--mark 'delete t)))
 878
 879 (defun guix-generation-list-execute ()
 880   "Delete marked generations."
 881   (interactive)
 882   (let ((marked (guix-list-get-marked-id-list 'delete)))
 883     (or marked
 884         (user-error "No generations marked for deletion"))
 885     (guix-delete-generations guix-profile marked (current-buffer))))
 886
 887 (provide 'guix-list)
 888
 889 ;;; guix-list.el ends here