emacs/guix-list.el

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