emacs/guix-ui-package.el

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