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