emacs/guix-ui-package.el

   1 ;;; guix-ui-package.el --- Interface for displaying packages  -*- 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 an interface for displaying packages and outputs
  23 ;; in 'list' and 'info' buffers, and commands for working with them.
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28 (require 'guix-buffer)
  29 (require 'guix-list)
  30 (require 'guix-info)
  31 (require 'guix-ui)
  32 (require 'guix-base)
  33 (require 'guix-backend)
  34 (require 'guix-guile)
  35 (require 'guix-entry)
  36 (require 'guix-utils)
  37 (require 'guix-hydra-build)
  38 (require 'guix-read)
  39 (require 'guix-license)
  40 (require 'guix-profiles)
  41
  42 (guix-ui-define-entry-type package)
  43 (guix-ui-define-entry-type output)
  44
  45 (defcustom guix-package-list-type 'output
  46   "Define how to display packages in 'list' buffer.
  47 Should be a symbol `package' or `output' (if `output', display each
  48 output on a separate line; if `package', display each package on
  49 a separate line)."
  50   :type '(choice (const :tag "List of packages" package)
  51                  (const :tag "List of outputs" output))
  52   :group 'guix-package)
  53
  54 (defcustom guix-package-info-type 'package
  55   "Define how to display packages in 'info' buffer.
  56 Should be a symbol `package' or `output' (if `output', display
  57 each output separately; if `package', display outputs inside
  58 package data)."
  59   :type '(choice (const :tag "Display packages" package)
  60                  (const :tag "Display outputs" output))
  61   :group 'guix-package)
  62
  63 (defun guix-package-get-display (profile search-type &rest search-values)
  64   "Search for packages/outputs and show results.
  65
  66 If PROFILE is nil, use `guix-current-profile'.
  67
  68 See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and
  69 SEARCH-VALUES.
  70
  71 Results are displayed in the list buffer, unless a single package
  72 is found and `guix-package-list-single' is nil."
  73   (let* ((args    (cl-list* (or profile guix-current-profile)
  74                             search-type search-values))
  75          (entries (guix-buffer-get-entries
  76                    'list guix-package-list-type args)))
  77     (if (or guix-package-list-single
  78             (null entries)
  79             (cdr entries))
  80         (guix-buffer-display-entries
  81          entries 'list guix-package-list-type args 'add)
  82       (guix-buffer-get-display-entries
  83        'info guix-package-info-type args 'add))))
  84
  85 (defun guix-package-entry->name-specification (entry &optional output)
  86   "Return name specification of the package ENTRY and OUTPUT."
  87   (guix-package-name-specification
  88    (guix-entry-value entry 'name)
  89    (guix-entry-value entry 'version)
  90    (or output (guix-entry-value entry 'output))))
  91
  92 (defun guix-package-entries->name-specifications (entries)
  93   "Return name specifications by the package or output ENTRIES."
  94   (cl-remove-duplicates (mapcar #'guix-package-entry->name-specification
  95                                 entries)
  96                         :test #'string=))
  97
  98 (defun guix-package-installed-outputs (entry)
  99   "Return a list of installed outputs for the package ENTRY."
 100   (mapcar (lambda (installed-entry)
 101             (guix-entry-value installed-entry 'output))
 102           (guix-entry-value entry 'installed)))
 103
 104 (defun guix-package-id-and-output-by-output-id (output-id)
 105   "Return a list (PACKAGE-ID OUTPUT) by OUTPUT-ID."
 106   (cl-multiple-value-bind (package-id-str output)
 107       (split-string output-id ":")
 108     (let ((package-id (string-to-number package-id-str)))
 109       (list (if (= 0 package-id) package-id-str package-id)
 110             output))))
 111
 112 \f
 113 ;;; Processing package actions
 114
 115 (defun guix-process-package-actions (profile actions
 116                                      &optional operation-buffer)
 117   "Process package ACTIONS on PROFILE.
 118 Each action is a list of the form:
 119
 120   (ACTION-TYPE PACKAGE-SPEC ...)
 121
 122 ACTION-TYPE is one of the following symbols: `install',
 123 `upgrade', `remove'/`delete'.
 124 PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)."
 125   (let (install upgrade remove)
 126     (mapc (lambda (action)
 127             (let ((action-type (car action))
 128                   (specs (cdr action)))
 129               (cl-case action-type
 130                 (install (setq install (append install specs)))
 131                 (upgrade (setq upgrade (append upgrade specs)))
 132                 ((remove delete) (setq remove (append remove specs))))))
 133           actions)
 134     (when (guix-continue-package-operation-p
 135            profile
 136            :install install :upgrade upgrade :remove remove)
 137       (guix-eval-in-repl
 138        (guix-make-guile-expression
 139         'process-package-actions profile
 140         :install install :upgrade upgrade :remove remove
 141         :use-substitutes? (or guix-use-substitutes 'f)
 142         :dry-run? (or guix-dry-run 'f))
 143        (and (not guix-dry-run) operation-buffer)))))
 144
 145 (cl-defun guix-continue-package-operation-p (profile
 146                                              &key install upgrade remove)
 147   "Return non-nil if a package operation should be continued.
 148 Ask a user if needed (see `guix-operation-confirm').
 149 INSTALL, UPGRADE, REMOVE are 'package action specifications'.
 150 See `guix-process-package-actions' for details."
 151   (or (null guix-operation-confirm)
 152       (let* ((entries (guix-ui-get-entries
 153                        profile 'package 'id
 154                        (append (mapcar #'car install)
 155                                (mapcar #'car upgrade)
 156                                (mapcar #'car remove))
 157                        '(id name version location)))
 158              (install-strings (guix-get-package-strings install entries))
 159              (upgrade-strings (guix-get-package-strings upgrade entries))
 160              (remove-strings  (guix-get-package-strings remove entries)))
 161         (if (or install-strings upgrade-strings remove-strings)
 162             (let ((buf (get-buffer-create guix-temp-buffer-name)))
 163               (with-current-buffer buf
 164                 (setq-local cursor-type nil)
 165                 (setq buffer-read-only nil)
 166                 (erase-buffer)
 167                 (insert "Profile: " profile "\n\n")
 168                 (guix-insert-package-strings install-strings "install")
 169                 (guix-insert-package-strings upgrade-strings "upgrade")
 170                 (guix-insert-package-strings remove-strings "remove")
 171                 (let ((win (temp-buffer-window-show
 172                             buf
 173                             '((display-buffer-reuse-window
 174                                display-buffer-at-bottom)
 175                               (window-height . fit-window-to-buffer)))))
 176                   (prog1 (guix-operation-prompt)
 177                     (quit-window nil win)))))
 178           (message "Nothing to be done.
 179 If Guix REPL was restarted, the data is not up-to-date.")
 180           nil))))
 181
 182 (defun guix-get-package-strings (specs entries)
 183   "Return short package descriptions for performing package actions.
 184 See `guix-process-package-actions' for the meaning of SPECS.
 185 ENTRIES is a list of package entries to get info about packages."
 186   (delq nil
 187         (mapcar
 188          (lambda (spec)
 189            (let* ((id (car spec))
 190                   (outputs (cdr spec))
 191                   (entry (guix-entry-by-id id entries)))
 192              (when entry
 193                (let ((location (guix-entry-value entry 'location)))
 194                  (concat (guix-package-entry->name-specification entry)
 195                          (when outputs
 196                            (concat ":"
 197                                    (guix-concat-strings outputs ",")))
 198                          (when location
 199                            (concat "\t(" location ")")))))))
 200          specs)))
 201
 202 (defun guix-insert-package-strings (strings action)
 203   "Insert information STRINGS at point for performing package ACTION."
 204   (when strings
 205     (insert "Package(s) to " (propertize action 'face 'bold) ":\n")
 206     (mapc (lambda (str)
 207             (insert "  " str "\n"))
 208           strings)
 209     (insert "\n")))
 210
 211 \f
 212 ;;; Package 'info'
 213
 214 (guix-ui-info-define-interface package
 215   :buffer-name "*Guix Package Info*"
 216   :format '(guix-package-info-insert-heading
 217             ignore
 218             (synopsis ignore (simple guix-package-info-synopsis))
 219             ignore
 220             (description ignore (simple guix-package-info-description))
 221             ignore
 222             (outputs simple guix-package-info-insert-outputs)
 223             (source simple guix-package-info-insert-source)
 224             (location format (format guix-package-location))
 225             (home-url format (format guix-url))
 226             (license format (format guix-package-license))
 227             (systems format guix-package-info-insert-systems)
 228             (inputs format (format guix-package-input))
 229             (native-inputs format (format guix-package-native-input))
 230             (propagated-inputs format
 231                                (format guix-package-propagated-input)))
 232   :titles '((home-url . "Home page")
 233             (systems . "Supported systems"))
 234   :required '(id name version installed non-unique))
 235
 236 (guix-info-define-interface installed-output
 237   :format '((path simple (indent guix-file))
 238             (dependencies simple (indent guix-file)))
 239   :titles '((path . "Store directory"))
 240   :reduced? t)
 241
 242 (defface guix-package-info-heading
 243   '((t :inherit guix-info-heading))
 244   "Face for package name and version headings."
 245   :group 'guix-package-info-faces)
 246
 247 (defface guix-package-info-name
 248   '((t :inherit font-lock-keyword-face))
 249   "Face used for a name of a package."
 250   :group 'guix-package-info-faces)
 251
 252 (defface guix-package-info-name-button
 253   '((t :inherit button))
 254   "Face used for a full name that can be used to describe a package."
 255   :group 'guix-package-info-faces)
 256
 257 (defface guix-package-info-version
 258   '((t :inherit font-lock-builtin-face))
 259   "Face used for a version of a package."
 260   :group 'guix-package-info-faces)
 261
 262 (defface guix-package-info-synopsis
 263   '((((type tty pc) (class color)) :weight bold)
 264     (t :height 1.1 :weight bold :inherit variable-pitch))
 265   "Face used for a synopsis of a package."
 266   :group 'guix-package-info-faces)
 267
 268 (defface guix-package-info-description
 269   '((t))
 270   "Face used for a description of a package."
 271   :group 'guix-package-info-faces)
 272
 273 (defface guix-package-info-license
 274   '((t :inherit font-lock-string-face))
 275   "Face used for a license of a package."
 276   :group 'guix-package-info-faces)
 277
 278 (defface guix-package-info-location
 279   '((t :inherit link))
 280   "Face used for a location of a package."
 281   :group 'guix-package-info-faces)
 282
 283 (defface guix-package-info-source
 284   '((t :inherit link :underline nil))
 285   "Face used for a source URL of a package."
 286   :group 'guix-package-info-faces)
 287
 288 (defface guix-package-info-installed-outputs
 289   '((default :weight bold)
 290     (((class color) (min-colors 88) (background light))
 291      :foreground "ForestGreen")
 292     (((class color) (min-colors 88) (background dark))
 293      :foreground "PaleGreen")
 294     (((class color) (min-colors 8))
 295      :foreground "green")
 296     (t :underline t))
 297   "Face used for installed outputs of a package."
 298   :group 'guix-package-info-faces)
 299
 300 (defface guix-package-info-uninstalled-outputs
 301   '((t :weight bold))
 302   "Face used for uninstalled outputs of a package."
 303   :group 'guix-package-info-faces)
 304
 305 (defface guix-package-info-obsolete
 306   '((t :inherit error))
 307   "Face used if a package is obsolete."
 308   :group 'guix-package-info-faces)
 309
 310 (defcustom guix-package-info-auto-find-source nil
 311   "If non-nil, find a source file after pressing a \"Show\" button.
 312 If nil, just display the source file path without finding."
 313   :type 'boolean
 314   :group 'guix-package-info)
 315
 316 (defcustom guix-package-info-auto-download-source t
 317   "If nil, do not automatically download a source file if it doesn't exist.
 318 After pressing a \"Show\" button, a derivation of the package
 319 source is calculated and a store file path is displayed.  If this
 320 variable is non-nil and the source file does not exist in the
 321 store, it will be automatically downloaded (with a possible
 322 prompt depending on `guix-operation-confirm' variable)."
 323   :type 'boolean
 324   :group 'guix-package-info)
 325
 326 (defvar guix-package-info-download-buffer nil
 327   "Buffer from which a current download operation was performed.")
 328
 329 (defvar guix-package-info-output-format "%-10s"
 330   "String used to format output names of the packages.
 331 It should be a '%s'-sequence.  After inserting an output name
 332 formatted with this string, an action button is inserted.")
 333
 334 (defvar guix-package-info-obsolete-string "(This package is obsolete)"
 335   "String used if a package is obsolete.")
 336
 337 (define-button-type 'guix-package-location
 338   :supertype 'guix
 339   'face 'guix-package-info-location
 340   'help-echo "Find location of this package"
 341   'action (lambda (btn)
 342             (guix-find-location (button-label btn))))
 343
 344 (define-button-type 'guix-package-license
 345   :supertype 'guix
 346   'face 'guix-package-info-license
 347   'help-echo "Browse license URL"
 348   'action (lambda (btn)
 349             (guix-browse-license-url (button-label btn))))
 350
 351 (define-button-type 'guix-package-name
 352   :supertype 'guix
 353   'face 'guix-package-info-name-button
 354   'help-echo "Describe this package"
 355   'action (lambda (btn)
 356             (guix-buffer-get-display-entries-current
 357              'info guix-package-info-type
 358              (list (guix-ui-current-profile)
 359                    'name (button-label btn))
 360              'add)))
 361
 362 (define-button-type 'guix-package-heading
 363   :supertype 'guix-package-name
 364   'face 'guix-package-info-heading)
 365
 366 (define-button-type 'guix-package-source
 367   :supertype 'guix
 368   'face 'guix-package-info-source
 369   'help-echo ""
 370   'action (lambda (_)
 371             ;; As a source may not be a real URL (e.g., "mirror://..."),
 372             ;; no action is bound to a source button.
 373             (message "Yes, this is the source URL. What did you expect?")))
 374
 375 (defun guix-package-info-insert-heading (entry)
 376   "Insert package ENTRY heading (name specification) at point."
 377   (guix-insert-button
 378    (guix-package-entry->name-specification entry)
 379    'guix-package-heading))
 380
 381 (defun guix-package-info-insert-systems (systems entry)
 382   "Insert supported package SYSTEMS at point."
 383   (guix-info-insert-value-format
 384    systems 'guix-hydra-build-system
 385    'action (lambda (btn)
 386              (let ((args (guix-hydra-build-latest-prompt-args
 387                           :job (button-get btn 'job-name)
 388                           :system (button-label btn))))
 389                (apply #'guix-hydra-build-get-display
 390                       'latest args)))
 391    'job-name (guix-package-name-specification
 392               (guix-entry-value entry 'name)
 393               (guix-entry-value entry 'version))))
 394
 395 (defmacro guix-package-info-define-insert-inputs (&optional type)
 396   "Define a face and a function for inserting package inputs.
 397 TYPE is a type of inputs.
 398 Function name is `guix-package-info-insert-TYPE-inputs'.
 399 Face name is `guix-package-info-TYPE-inputs'."
 400   (let* ((type-str (symbol-name type))
 401          (type-name (and type (concat type-str "-")))
 402          (type-desc (and type (concat type-str " ")))
 403          (face (intern (concat "guix-package-info-" type-name "inputs")))
 404          (btn  (intern (concat "guix-package-" type-name "input"))))
 405     `(progn
 406        (defface ,face
 407          '((t :inherit guix-package-info-name-button))
 408          ,(concat "Face used for " type-desc "inputs of a package.")
 409          :group 'guix-package-info-faces)
 410
 411        (define-button-type ',btn
 412          :supertype 'guix-package-name
 413          'face ',face))))
 414
 415 (guix-package-info-define-insert-inputs)
 416 (guix-package-info-define-insert-inputs native)
 417 (guix-package-info-define-insert-inputs propagated)
 418
 419 (defun guix-package-info-insert-outputs (outputs entry)
 420   "Insert OUTPUTS from package ENTRY at point."
 421   (and (guix-entry-value entry 'obsolete)
 422        (guix-package-info-insert-obsolete-text))
 423   (and (guix-entry-value entry 'non-unique)
 424        (guix-entry-value entry 'installed)
 425        (guix-package-info-insert-non-unique-text
 426         (guix-package-entry->name-specification entry)))
 427   (insert "\n")
 428   (dolist (output outputs)
 429     (guix-package-info-insert-output output entry)))
 430
 431 (defun guix-package-info-insert-obsolete-text ()
 432   "Insert a message about obsolete package at point."
 433   (guix-info-insert-indent)
 434   (guix-format-insert guix-package-info-obsolete-string
 435                       'guix-package-info-obsolete))
 436
 437 (defun guix-package-info-insert-non-unique-text (full-name)
 438   "Insert a message about non-unique package with FULL-NAME at point."
 439   (insert "\n")
 440   (guix-info-insert-indent)
 441   (insert "Installed outputs are displayed for a non-unique ")
 442   (guix-insert-button full-name 'guix-package-name)
 443   (insert " package."))
 444
 445 (defun guix-package-info-insert-output (output entry)
 446   "Insert OUTPUT at point.
 447 Make some fancy text with buttons and additional stuff if the
 448 current OUTPUT is installed (if there is such output in
 449 `installed' parameter of a package ENTRY)."
 450   (let* ((installed (guix-entry-value entry 'installed))
 451          (obsolete  (guix-entry-value entry 'obsolete))
 452          (installed-entry (cl-find-if
 453                            (lambda (entry)
 454                              (string= (guix-entry-value entry 'output)
 455                                       output))
 456                            installed))
 457          (action-type (if installed-entry 'delete 'install))
 458          (profile (guix-ui-current-profile)))
 459     (guix-info-insert-indent)
 460     (guix-format-insert output
 461                         (if installed-entry
 462                             'guix-package-info-installed-outputs
 463                           'guix-package-info-uninstalled-outputs)
 464                         guix-package-info-output-format)
 465     ;; Do not allow a user to install/delete anything to/from a system
 466     ;; profile, so add action buttons only for non-system profiles.
 467     (when (and profile
 468                (not (guix-system-profile? profile)))
 469       (guix-package-info-insert-action-button action-type entry output)
 470       (when obsolete
 471         (guix-info-insert-indent)
 472         (guix-package-info-insert-action-button 'upgrade entry output)))
 473     (insert "\n")
 474     (when installed-entry
 475       (guix-info-insert-entry installed-entry 'installed-output 2))))
 476
 477 (defun guix-package-info-insert-action-button (type entry output)
 478   "Insert button to process an action on a package OUTPUT at point.
 479 TYPE is one of the following symbols: `install', `delete', `upgrade'.
 480 ENTRY is an alist with package info."
 481   (let ((type-str  (capitalize (symbol-name type)))
 482         (full-name (guix-package-entry->name-specification entry output)))
 483     (guix-info-insert-action-button
 484      type-str
 485      (lambda (btn)
 486        (guix-process-package-actions
 487         (guix-ui-current-profile)
 488         `((,(button-get btn 'action-type) (,(button-get btn 'id)
 489                                            ,(button-get btn 'output))))
 490         (current-buffer)))
 491      (concat type-str " '" full-name "'")
 492      'action-type type
 493      'id (or (guix-entry-value entry 'package-id)
 494              (guix-entry-id entry))
 495      'output output)))
 496
 497 (defun guix-package-info-show-source (entry-id package-id)
 498   "Show file name of a package source in the current info buffer.
 499 Find the file if needed (see `guix-package-info-auto-find-source').
 500 ENTRY-ID is an ID of the current entry (package or output).
 501 PACKAGE-ID is an ID of the package which source to show."
 502   (let* ((entries (guix-buffer-current-entries))
 503          (entry   (guix-entry-by-id entry-id entries))
 504          (file    (guix-package-source-path package-id)))
 505     (or file
 506         (error "Couldn't define file name of the package source"))
 507     (let* ((new-entry (cons (cons 'source-file file)
 508                             entry))
 509            (new-entries (guix-replace-entry entry-id new-entry entries)))
 510       (setf (guix-buffer-item-entries guix-buffer-item)
 511             new-entries)
 512       (guix-buffer-redisplay-goto-button)
 513       (if (file-exists-p file)
 514           (if guix-package-info-auto-find-source
 515               (guix-find-file file)
 516             (message "The source store path is displayed."))
 517         (if guix-package-info-auto-download-source
 518             (guix-package-info-download-source package-id)
 519           (message "The source does not exist in the store."))))))
 520
 521 (defun guix-package-info-download-source (package-id)
 522   "Download a source of the package PACKAGE-ID."
 523   (setq guix-package-info-download-buffer (current-buffer))
 524   (guix-package-source-build-derivation
 525    package-id
 526    "The source does not exist in the store. Download it?"))
 527
 528 (defun guix-package-info-insert-source (source entry)
 529   "Insert SOURCE from package ENTRY at point.
 530 SOURCE is a list of URLs."
 531   (if (null source)
 532       (guix-format-insert nil)
 533     (let* ((source-file (guix-entry-value entry 'source-file))
 534            (entry-id    (guix-entry-id entry))
 535            (package-id  (or (guix-entry-value entry 'package-id)
 536                             entry-id)))
 537       (if (null source-file)
 538           (guix-info-insert-action-button
 539            "Show"
 540            (lambda (btn)
 541              (guix-package-info-show-source (button-get btn 'entry-id)
 542                                             (button-get btn 'package-id)))
 543            "Show the source store directory of the current package"
 544            'entry-id entry-id
 545            'package-id package-id)
 546         (unless (file-exists-p source-file)
 547           (guix-info-insert-action-button
 548            "Download"
 549            (lambda (btn)
 550              (guix-package-info-download-source
 551               (button-get btn 'package-id)))
 552            "Download the source into the store"
 553            'package-id package-id))
 554         (guix-info-insert-value-indent source-file 'guix-file))
 555       (guix-info-insert-value-indent source 'guix-package-source))))
 556
 557 (defun guix-package-info-redisplay-after-download ()
 558   "Redisplay an 'info' buffer after downloading the package source.
 559 This function is used to hide a \"Download\" button if needed."
 560   (when (buffer-live-p guix-package-info-download-buffer)
 561     (with-current-buffer guix-package-info-download-buffer
 562       (guix-buffer-redisplay-goto-button))
 563     (setq guix-package-info-download-buffer nil)))
 564
 565 (add-hook 'guix-after-source-download-hook
 566           'guix-package-info-redisplay-after-download)
 567
 568 \f
 569 ;;; Package 'list'
 570
 571 (guix-ui-list-define-interface package
 572   :buffer-name "*Guix Package List*"
 573   :format '((name guix-package-list-get-name 20 t)
 574             (version nil 10 nil)
 575             (outputs nil 13 t)
 576             (installed guix-package-list-get-installed-outputs 13 t)
 577             (synopsis guix-list-get-one-line 30 nil))
 578   :sort-key '(name)
 579   :marks '((install . ?I)
 580            (upgrade . ?U)
 581            (delete  . ?D)))
 582
 583 (let ((map guix-package-list-mode-map))
 584   (define-key map (kbd "B")   'guix-package-list-latest-builds)
 585   (define-key map (kbd "e")   'guix-package-list-edit)
 586   (define-key map (kbd "x")   'guix-package-list-execute)
 587   (define-key map (kbd "i")   'guix-package-list-mark-install)
 588   (define-key map (kbd "d")   'guix-package-list-mark-delete)
 589   (define-key map (kbd "U")   'guix-package-list-mark-upgrade)
 590   (define-key map (kbd "^")   'guix-package-list-mark-upgrades))
 591
 592 (defface guix-package-list-installed
 593   '((t :inherit guix-package-info-installed-outputs))
 594   "Face used if there are installed outputs for the current package."
 595   :group 'guix-package-list-faces)
 596
 597 (defface guix-package-list-obsolete
 598   '((t :inherit guix-package-info-obsolete))
 599   "Face used if a package is obsolete."
 600   :group 'guix-package-list-faces)
 601
 602 (defcustom guix-package-list-generation-marking-enabled nil
 603   "If non-nil, allow putting marks in a list with 'generation packages'.
 604
 605 By default this is disabled, because it may be confusing.  For
 606 example, a package is installed in some generation, so a user can
 607 mark it for deletion in the list of packages from this
 608 generation, but the package may not be installed in the latest
 609 generation, so actually it cannot be deleted.
 610
 611 If you managed to understand the explanation above or if you
 612 really know what you do or if you just don't care, you can set
 613 this variable to t.  It should not do much harm anyway (most
 614 likely)."
 615   :type 'boolean
 616   :group 'guix-package-list)
 617
 618 (defun guix-package-list-get-name (name entry)
 619   "Return NAME of the package ENTRY.
 620 Colorize it with `guix-package-list-installed' or
 621 `guix-package-list-obsolete' if needed."
 622   (guix-get-string name
 623                    (cond ((guix-entry-value entry 'obsolete)
 624                           'guix-package-list-obsolete)
 625                          ((guix-entry-value entry 'installed)
 626                           'guix-package-list-installed))))
 627
 628 (defun guix-package-list-get-installed-outputs (installed &optional _)
 629   "Return string with outputs from INSTALLED entries."
 630   (guix-get-string
 631    (mapcar (lambda (entry)
 632              (guix-entry-value entry 'output))
 633            installed)))
 634
 635 (defun guix-package-list-marking-check ()
 636   "Signal an error if marking is disabled for the current buffer."
 637   (when (and (not guix-package-list-generation-marking-enabled)
 638              (or (derived-mode-p 'guix-package-list-mode)
 639                  (derived-mode-p 'guix-output-list-mode))
 640              (eq (guix-ui-current-search-type) 'generation))
 641     (error "Action marks are disabled for lists of 'generation packages'")))
 642
 643 (defun guix-package-list-mark-outputs (mark default
 644                                        &optional prompt available)
 645   "Mark the current package with MARK and move to the next line.
 646 If PROMPT is non-nil, use it to ask a user for outputs from
 647 AVAILABLE list, otherwise mark all DEFAULT outputs."
 648   (let ((outputs (if prompt
 649                      (guix-completing-read-multiple
 650                       prompt available nil t)
 651                    default)))
 652     (apply #'guix-list--mark mark t outputs)))
 653
 654 (defun guix-package-list-mark-install (&optional arg)
 655   "Mark the current package for installation and move to the next line.
 656 With ARG, prompt for the outputs to install (several outputs may
 657 be separated with \",\")."
 658   (interactive "P")
 659   (guix-package-list-marking-check)
 660   (let* ((entry     (guix-list-current-entry))
 661          (all       (guix-entry-value entry 'outputs))
 662          (installed (guix-package-installed-outputs entry))
 663          (available (cl-set-difference all installed :test #'string=)))
 664     (or available
 665         (user-error "This package is already installed"))
 666     (guix-package-list-mark-outputs
 667      'install '("out")
 668      (and arg "Output(s) to install: ")
 669      available)))
 670
 671 (defun guix-package-list-mark-delete (&optional arg)
 672   "Mark the current package for deletion and move to the next line.
 673 With ARG, prompt for the outputs to delete (several outputs may
 674 be separated with \",\")."
 675   (interactive "P")
 676   (guix-package-list-marking-check)
 677   (let* ((entry (guix-list-current-entry))
 678          (installed (guix-package-installed-outputs entry)))
 679     (or installed
 680         (user-error "This package is not installed"))
 681     (guix-package-list-mark-outputs
 682      'delete installed
 683      (and arg "Output(s) to delete: ")
 684      installed)))
 685
 686 (defun guix-package-list-mark-upgrade (&optional arg)
 687   "Mark the current package for upgrading and move to the next line.
 688 With ARG, prompt for the outputs to upgrade (several outputs may
 689 be separated with \",\")."
 690   (interactive "P")
 691   (guix-package-list-marking-check)
 692   (let* ((entry (guix-list-current-entry))
 693          (installed (guix-package-installed-outputs entry)))
 694     (or installed
 695         (user-error "This package is not installed"))
 696     (when (or (guix-entry-value entry 'obsolete)
 697               (y-or-n-p "This package is not obsolete.  Try to upgrade it anyway? "))
 698       (guix-package-list-mark-outputs
 699        'upgrade installed
 700        (and arg "Output(s) to upgrade: ")
 701        installed))))
 702
 703 (defun guix-package-mark-upgrades (fun)
 704   "Mark all obsolete packages for upgrading.
 705 Use FUN to perform marking of the current line.  FUN should
 706 take an entry as argument."
 707   (guix-package-list-marking-check)
 708   (let ((obsolete (cl-remove-if-not
 709                    (lambda (entry)
 710                      (guix-entry-value entry 'obsolete))
 711                    (guix-buffer-current-entries))))
 712     (guix-list-for-each-line
 713      (lambda ()
 714        (let* ((id (guix-list-current-id))
 715               (entry (cl-find-if
 716                       (lambda (entry)
 717                         (equal id (guix-entry-id entry)))
 718                       obsolete)))
 719          (when entry
 720            (funcall fun entry)))))))
 721
 722 (defun guix-package-list-mark-upgrades ()
 723   "Mark all obsolete packages for upgrading."
 724   (interactive)
 725   (guix-package-mark-upgrades
 726    (lambda (entry)
 727      (apply #'guix-list--mark
 728             'upgrade nil
 729             (guix-package-installed-outputs entry)))))
 730
 731 (defun guix-package-assert-non-system-profile ()
 732   "Verify that the current profile is not a system one.
 733 The current profile is the one used by the current buffer."
 734   (let ((profile (guix-ui-current-profile)))
 735     (and profile
 736          (guix-system-profile? profile)
 737          (user-error "Packages cannot be installed or removed to/from \
 738 profile '%s'.
 739 Use 'guix system reconfigure' shell command to modify a system profile."
 740                      profile))))
 741
 742 (defun guix-package-execute-actions (fun)
 743   "Perform actions on the marked packages.
 744 Use FUN to define actions suitable for `guix-process-package-actions'.
 745 FUN should take action-type as argument."
 746   (guix-package-assert-non-system-profile)
 747   (let ((actions (delq nil
 748                        (mapcar fun '(install delete upgrade)))))
 749     (if actions
 750         (guix-process-package-actions (guix-ui-current-profile)
 751                                       actions (current-buffer))
 752       (user-error "No operations specified"))))
 753
 754 (defun guix-package-list-execute ()
 755   "Perform actions on the marked packages."
 756   (interactive)
 757   (guix-package-execute-actions #'guix-package-list-make-action))
 758
 759 (defun guix-package-list-make-action (action-type)
 760   "Return action specification for the packages marked with ACTION-TYPE.
 761 Return nil, if there are no packages marked with ACTION-TYPE.
 762 The specification is suitable for `guix-process-package-actions'."
 763   (let ((specs (guix-list-get-marked-args action-type)))
 764     (and specs (cons action-type specs))))
 765
 766 (defun guix-package-list-edit (&optional directory)
 767   "Go to the location of the current package.
 768 See `guix-find-location' for the meaning of DIRECTORY."
 769   (interactive (list (guix-read-directory)))
 770   (guix-edit (guix-list-current-id) directory))
 771
 772 (defun guix-package-list-latest-builds (number &rest args)
 773   "Display latest NUMBER of Hydra builds of the current package.
 774 Interactively, prompt for NUMBER.  With prefix argument, prompt
 775 for all ARGS."
 776   (interactive
 777    (let ((entry (guix-list-current-entry)))
 778      (guix-hydra-build-latest-prompt-args
 779       :job (guix-package-name-specification
 780             (guix-entry-value entry 'name)
 781             (guix-entry-value entry 'version)))))
 782   (apply #'guix-hydra-latest-builds number args))
 783
 784 \f
 785 ;;; Output 'info'
 786
 787 (guix-ui-info-define-interface output
 788   :buffer-name "*Guix Package Info*"
 789   :format '((name format (format guix-package-info-name))
 790             (version format guix-output-info-insert-version)
 791             (output format guix-output-info-insert-output)
 792             (synopsis simple (indent guix-package-info-synopsis))
 793             (source simple guix-package-info-insert-source)
 794             (path simple (indent guix-file))
 795             (dependencies simple (indent guix-file))
 796             (location format (format guix-package-location))
 797             (home-url format (format guix-url))
 798             (license format (format guix-package-license))
 799             (systems format guix-package-info-insert-systems)
 800             (inputs format (format guix-package-input))
 801             (native-inputs format (format guix-package-native-input))
 802             (propagated-inputs format
 803                                (format guix-package-propagated-input))
 804             (description simple (indent guix-package-info-description)))
 805   :titles guix-package-info-titles
 806   :required '(id package-id installed non-unique))
 807
 808 (defun guix-output-info-insert-version (version entry)
 809   "Insert output VERSION and obsolete text if needed at point."
 810   (guix-info-insert-value-format version
 811                                  'guix-package-info-version)
 812   (and (guix-entry-value entry 'obsolete)
 813        (guix-package-info-insert-obsolete-text)))
 814
 815 (defun guix-output-info-insert-output (output entry)
 816   "Insert OUTPUT and action buttons at point."
 817   (let* ((installed   (guix-entry-value entry 'installed))
 818          (obsolete    (guix-entry-value entry 'obsolete))
 819          (action-type (if installed 'delete 'install)))
 820     (guix-info-insert-value-format
 821      output
 822      (if installed
 823          'guix-package-info-installed-outputs
 824        'guix-package-info-uninstalled-outputs))
 825     (guix-info-insert-indent)
 826     (guix-package-info-insert-action-button action-type entry output)
 827     (when obsolete
 828       (guix-info-insert-indent)
 829       (guix-package-info-insert-action-button 'upgrade entry output))))
 830
 831 \f
 832 ;;; Output 'list'
 833
 834 (guix-ui-list-define-interface output
 835   :buffer-name "*Guix Package List*"
 836   :describe-function 'guix-output-list-describe
 837   :format '((name guix-package-list-get-name 20 t)
 838             (version nil 10 nil)
 839             (output nil 9 t)
 840             (installed nil 12 t)
 841             (synopsis guix-list-get-one-line 30 nil))
 842   :required '(id package-id)
 843   :sort-key '(name)
 844   :marks '((install . ?I)
 845            (upgrade . ?U)
 846            (delete  . ?D)))
 847
 848 (let ((map guix-output-list-mode-map))
 849   (define-key map (kbd "B")   'guix-package-list-latest-builds)
 850   (define-key map (kbd "e")   'guix-output-list-edit)
 851   (define-key map (kbd "x")   'guix-output-list-execute)
 852   (define-key map (kbd "i")   'guix-output-list-mark-install)
 853   (define-key map (kbd "d")   'guix-output-list-mark-delete)
 854   (define-key map (kbd "U")   'guix-output-list-mark-upgrade)
 855   (define-key map (kbd "^")   'guix-output-list-mark-upgrades))
 856
 857 (defun guix-output-list-mark-install ()
 858   "Mark the current output for installation and move to the next line."
 859   (interactive)
 860   (guix-package-list-marking-check)
 861   (let* ((entry     (guix-list-current-entry))
 862          (installed (guix-entry-value entry 'installed)))
 863     (if installed
 864         (user-error "This output is already installed")
 865       (guix-list--mark 'install t))))
 866
 867 (defun guix-output-list-mark-delete ()
 868   "Mark the current output for deletion and move to the next line."
 869   (interactive)
 870   (guix-package-list-marking-check)
 871   (let* ((entry     (guix-list-current-entry))
 872          (installed (guix-entry-value entry 'installed)))
 873     (if installed
 874         (guix-list--mark 'delete t)
 875       (user-error "This output is not installed"))))
 876
 877 (defun guix-output-list-mark-upgrade ()
 878   "Mark the current output for upgrading and move to the next line."
 879   (interactive)
 880   (guix-package-list-marking-check)
 881   (let* ((entry     (guix-list-current-entry))
 882          (installed (guix-entry-value entry 'installed)))
 883     (or installed
 884         (user-error "This output is not installed"))
 885     (when (or (guix-entry-value entry 'obsolete)
 886               (y-or-n-p "This output is not obsolete.  Try to upgrade it anyway? "))
 887       (guix-list--mark 'upgrade t))))
 888
 889 (defun guix-output-list-mark-upgrades ()
 890   "Mark all obsolete package outputs for upgrading."
 891   (interactive)
 892   (guix-package-mark-upgrades
 893    (lambda (_) (guix-list--mark 'upgrade))))
 894
 895 (defun guix-output-list-execute ()
 896   "Perform actions on the marked outputs."
 897   (interactive)
 898   (guix-package-execute-actions #'guix-output-list-make-action))
 899
 900 (defun guix-output-list-make-action (action-type)
 901   "Return action specification for the outputs marked with ACTION-TYPE.
 902 Return nil, if there are no outputs marked with ACTION-TYPE.
 903 The specification is suitable for `guix-process-output-actions'."
 904   (let ((ids (guix-list-get-marked-id-list action-type)))
 905     (and ids (cons action-type
 906                    (mapcar #'guix-package-id-and-output-by-output-id
 907                            ids)))))
 908
 909 (defun guix-output-list-describe (ids)
 910   "Describe outputs with IDS (list of output identifiers).
 911 See `guix-package-info-type'."
 912   (if (eq guix-package-info-type 'output)
 913       (guix-buffer-get-display-entries
 914        'info 'output
 915        (cl-list* (guix-ui-current-profile) 'id ids)
 916        'add)
 917     (let ((pids (mapcar (lambda (oid)
 918                           (car (guix-package-id-and-output-by-output-id
 919                                 oid)))
 920                         ids)))
 921       (guix-buffer-get-display-entries
 922        'info 'package
 923        (cl-list* (guix-ui-current-profile)
 924                  'id (cl-remove-duplicates pids))
 925        'add))))
 926
 927 (defun guix-output-list-edit (&optional directory)
 928   "Go to the location of the current package.
 929 See `guix-find-location' for the meaning of DIRECTORY."
 930   (interactive (list (guix-read-directory)))
 931   (guix-edit (guix-entry-value (guix-list-current-entry)
 932                                'package-id)
 933              directory))
 934
 935 \f
 936 ;;; Interactive commands
 937
 938 (defvar guix-package-search-params '(name synopsis description)
 939   "Default list of package parameters for searching by regexp.")
 940
 941 (defvar guix-package-search-history nil
 942   "A history of minibuffer prompts.")
 943
 944 ;;;###autoload
 945 (defun guix-packages-by-name (name &optional profile)
 946   "Display Guix packages with NAME.
 947 NAME is a string with name specification.  It may optionally contain
 948 a version number.  Examples: \"guile\", \"guile-2.0.11\".
 949
 950 If PROFILE is nil, use `guix-current-profile'.
 951 Interactively with prefix, prompt for PROFILE."
 952   (interactive
 953    (list (guix-read-package-name)
 954          (guix-ui-read-profile)))
 955   (guix-package-get-display profile 'name name))
 956
 957 ;;;###autoload
 958 (defun guix-packages-by-license (license &optional profile)
 959   "Display Guix packages with LICENSE.
 960 LICENSE is a license name string.
 961 If PROFILE is nil, use `guix-current-profile'.
 962 Interactively with prefix, prompt for PROFILE."
 963   (interactive
 964    (list (guix-read-license-name)
 965          (guix-ui-read-profile)))
 966   (guix-package-get-display profile 'license license))
 967
 968 ;;;###autoload
 969 (defun guix-search-by-regexp (regexp &optional params profile)
 970   "Search for Guix packages by REGEXP.
 971 PARAMS are package parameters that should be searched.
 972 If PARAMS are not specified, use `guix-package-search-params'.
 973
 974 If PROFILE is nil, use `guix-current-profile'.
 975 Interactively with prefix, prompt for PROFILE."
 976   (interactive
 977    (list (read-regexp "Regexp: " nil 'guix-package-search-history)
 978          nil (guix-ui-read-profile)))
 979   (guix-package-get-display profile 'regexp regexp
 980                             (or params guix-package-search-params)))
 981
 982 ;;;###autoload
 983 (defun guix-search-by-name (regexp &optional profile)
 984   "Search for Guix packages matching REGEXP in a package name.
 985 If PROFILE is nil, use `guix-current-profile'.
 986 Interactively with prefix, prompt for PROFILE."
 987   (interactive
 988    (list (read-string "Package name by regexp: "
 989                       nil 'guix-package-search-history)
 990          (guix-ui-read-profile)))
 991   (guix-search-by-regexp regexp '(name) profile))
 992
 993 ;;;###autoload
 994 (defun guix-installed-packages (&optional profile)
 995   "Display information about installed Guix packages.
 996 If PROFILE is nil, use `guix-current-profile'.
 997 Interactively with prefix, prompt for PROFILE."
 998   (interactive (list (guix-ui-read-profile)))
 999   (guix-package-get-display profile 'installed))
1000
1001 ;;;###autoload
1002 (defun guix-installed-user-packages ()
1003   "Display information about Guix packages installed in a user profile."
1004   (interactive)
1005   (guix-installed-packages guix-user-profile))
1006
1007 ;;;###autoload
1008 (defun guix-installed-system-packages ()
1009   "Display information about Guix packages installed in a system profile."
1010   (interactive)
1011   (guix-installed-packages
1012    (guix-packages-profile guix-system-profile nil t)))
1013
1014 ;;;###autoload
1015 (defun guix-obsolete-packages (&optional profile)
1016   "Display information about obsolete Guix packages.
1017 If PROFILE is nil, use `guix-current-profile'.
1018 Interactively with prefix, prompt for PROFILE."
1019   (interactive (list (guix-ui-read-profile)))
1020   (guix-package-get-display profile 'obsolete))
1021
1022 ;;;###autoload
1023 (defun guix-all-available-packages (&optional profile)
1024   "Display information about all available Guix packages.
1025 If PROFILE is nil, use `guix-current-profile'.
1026 Interactively with prefix, prompt for PROFILE."
1027   (interactive (list (guix-ui-read-profile)))
1028   (guix-package-get-display profile 'all-available))
1029
1030 ;;;###autoload
1031 (defun guix-newest-available-packages (&optional profile)
1032   "Display information about the newest available Guix packages.
1033 If PROFILE is nil, use `guix-current-profile'.
1034 Interactively with prefix, prompt for PROFILE."
1035   (interactive (list (guix-ui-read-profile)))
1036   (guix-package-get-display profile 'newest-available))
1037
1038 (provide 'guix-ui-package)
1039
1040 ;;; guix-ui-package.el ends here