emacs/guix-info.el

   1 ;;; guix-info.el --- Info buffers for displaying entries   -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
   4 ;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
   5
   6 ;; This file is part of GNU Guix.
   7
   8 ;; GNU Guix is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; GNU Guix is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This file provides a help-like buffer for displaying information
  24 ;; about Guix packages and generations.
  25
  26 ;;; Code:
  27
  28 (require 'guix-base)
  29 (require 'guix-utils)
  30
  31 (defgroup guix-info nil
  32   "General settings for info buffers."
  33   :prefix "guix-info-"
  34   :group 'guix)
  35
  36 (defgroup guix-info-faces nil
  37   "Faces for info buffers."
  38   :group 'guix-info
  39   :group 'guix-faces)
  40
  41 (defface guix-info-param-title
  42   '((t :inherit font-lock-type-face))
  43   "Face used for titles of parameters."
  44   :group 'guix-info-faces)
  45
  46 (defface guix-info-file-path
  47   '((t :inherit link))
  48   "Face used for file paths."
  49   :group 'guix-info-faces)
  50
  51 (defface guix-info-url
  52   '((t :inherit link))
  53   "Face used for URLs."
  54   :group 'guix-info-faces)
  55
  56 (defface guix-info-time
  57   '((t :inherit font-lock-constant-face))
  58   "Face used for timestamps."
  59   :group 'guix-info-faces)
  60
  61 (defface guix-info-action-button
  62   '((((type x w32 ns) (class color))
  63      :box (:line-width 2 :style released-button)
  64      :background "lightgrey" :foreground "black")
  65     (t :inherit button))
  66   "Face used for action buttons."
  67   :group 'guix-info-faces)
  68
  69 (defface guix-info-action-button-mouse
  70   '((((type x w32 ns) (class color))
  71      :box (:line-width 2 :style released-button)
  72      :background "grey90" :foreground "black")
  73     (t :inherit highlight))
  74   "Mouse face used for action buttons."
  75   :group 'guix-info-faces)
  76
  77 (defcustom guix-info-ignore-empty-vals nil
  78   "If non-nil, do not display parameters with nil values."
  79   :type 'boolean
  80   :group 'guix-info)
  81
  82 (defvar guix-info-param-title-format "%-18s: "
  83   "String used to format a title of a parameter.
  84 It should be a '%s'-sequence.  After inserting a title formatted
  85 with this string, a value of the parameter is inserted.
  86 This string is used by `guix-info-insert-title-default'.")
  87
  88 (defvar guix-info-multiline-prefix (make-string 20 ?\s)
  89   "String used to format multi-line parameter values.
  90 If a value occupies more than one line, this string is inserted
  91 in the beginning of each line after the first one.
  92 This string is used by `guix-info-insert-val-default'.")
  93
  94 (defvar guix-info-indent 2
  95   "Number of spaces used to indent various parts of inserted text.")
  96
  97 (defvar guix-info-fill-column 60
  98   "Column used for filling (word wrapping) parameters with long lines.
  99 If a value is not multi-line and it occupies more than this
 100 number of characters, it will be split into several lines.")
 101
 102 (defvar guix-info-delimiter "\n\f\n"
 103   "String used to separate entries.")
 104
 105 (defvar guix-info-insert-methods
 106   '((package
 107      (name              guix-package-info-name)
 108      (version           guix-package-info-version)
 109      (license           guix-package-info-license)
 110      (synopsis          guix-package-info-synopsis)
 111      (description       guix-package-info-insert-description
 112                         guix-info-insert-title-simple)
 113      (outputs           guix-package-info-insert-outputs
 114                         guix-info-insert-title-simple)
 115      (source            guix-package-info-insert-source
 116                         guix-info-insert-title-simple)
 117      (home-url          guix-info-insert-url)
 118      (inputs            guix-package-info-insert-inputs)
 119      (native-inputs     guix-package-info-insert-native-inputs)
 120      (propagated-inputs guix-package-info-insert-propagated-inputs)
 121      (location          guix-package-info-insert-location))
 122     (installed
 123      (path              guix-package-info-insert-output-path
 124                         guix-info-insert-title-simple)
 125      (dependencies      guix-package-info-insert-output-dependencies
 126                         guix-info-insert-title-simple))
 127     (output
 128      (name              guix-package-info-name)
 129      (version           guix-output-info-insert-version)
 130      (output            guix-output-info-insert-output)
 131      (source            guix-package-info-insert-source
 132                         guix-info-insert-title-simple)
 133      (path              guix-package-info-insert-output-path
 134                         guix-info-insert-title-simple)
 135      (dependencies      guix-package-info-insert-output-dependencies
 136                         guix-info-insert-title-simple)
 137      (license           guix-package-info-license)
 138      (synopsis          guix-package-info-synopsis)
 139      (description       guix-package-info-insert-description
 140                         guix-info-insert-title-simple)
 141      (home-url          guix-info-insert-url)
 142      (inputs            guix-package-info-insert-inputs)
 143      (native-inputs     guix-package-info-insert-native-inputs)
 144      (propagated-inputs guix-package-info-insert-propagated-inputs)
 145      (location          guix-package-info-insert-location))
 146     (generation
 147      (number            guix-generation-info-insert-number)
 148      (current           guix-generation-info-insert-current)
 149      (path              guix-info-insert-file-path)
 150      (time              guix-info-insert-time)))
 151   "Methods for inserting parameter values.
 152 Each element of the list should have a form:
 153
 154   (ENTRY-TYPE . ((PARAM INSERT-VALUE [INSERT-TITLE]) ...))
 155
 156 INSERT-VALUE may be either nil, a face name or a function.  If it
 157 is nil or a face, `guix-info-insert-val-default' function is
 158 called with parameter value and INSERT-VALUE as arguments.  If it
 159 is a function, this function is called with parameter value and
 160 entry info (alist of parameters and their values) as arguments.
 161
 162 INSERT-TITLE may be either nil, a face name or a function.  If it
 163 is nil or a face, `guix-info-insert-title-default' function is
 164 called with parameter title and INSERT-TITLE as arguments.  If it
 165 is a function, this function is called with parameter title as
 166 argument.")
 167
 168 (defvar guix-info-displayed-params
 169   '((package name version synopsis outputs source location home-url
 170              license inputs native-inputs propagated-inputs description)
 171     (output name version output synopsis source path dependencies location
 172             home-url license inputs native-inputs propagated-inputs
 173             description)
 174     (installed path dependencies)
 175     (generation number prev-number current time path))
 176   "List of displayed entry parameters.
 177 Each element of the list should have a form:
 178
 179   (ENTRY-TYPE . (PARAM ...))
 180
 181 The order of displayed parameters is the same as in this list.")
 182
 183 (defun guix-info-get-insert-methods (entry-type param)
 184   "Return list of insert methods for parameter PARAM of ENTRY-TYPE.
 185 See `guix-info-insert-methods' for details."
 186   (guix-assq-value guix-info-insert-methods
 187                    entry-type param))
 188
 189 (defun guix-info-get-displayed-params (entry-type)
 190   "Return parameters of ENTRY-TYPE that should be displayed."
 191   (guix-assq-value guix-info-displayed-params
 192                    entry-type))
 193
 194 (defun guix-info-get-indent (&optional level)
 195   "Return `guix-info-indent' \"multiplied\" by LEVEL spaces.
 196 LEVEL is 1 by default."
 197   (make-string (* guix-info-indent (or level 1)) ?\s))
 198
 199 (defun guix-info-insert-indent (&optional level)
 200   "Insert `guix-info-indent' spaces LEVEL times (1 by default)."
 201   (insert (guix-info-get-indent level)))
 202
 203 (defun guix-info-insert-entries (entries entry-type)
 204   "Display ENTRIES of ENTRY-TYPE in the current info buffer.
 205 ENTRIES should have a form of `guix-entries'."
 206   (guix-mapinsert (lambda (entry)
 207                     (guix-info-insert-entry entry entry-type))
 208                   entries
 209                   guix-info-delimiter))
 210
 211 (defun guix-info-insert-entry-default (entry entry-type
 212                                        &optional indent-level)
 213   "Insert ENTRY of ENTRY-TYPE into the current info buffer.
 214 If INDENT-LEVEL is non-nil, indent displayed information by this
 215 number of `guix-info-indent' spaces."
 216   (let ((region-beg (point)))
 217     (mapc (lambda (param)
 218             (guix-info-insert-param param entry entry-type))
 219           (guix-info-get-displayed-params entry-type))
 220     (when indent-level
 221       (indent-rigidly region-beg (point)
 222                       (* indent-level guix-info-indent)))))
 223
 224 (defun guix-info-insert-entry (entry entry-type &optional indent-level)
 225   "Insert ENTRY of ENTRY-TYPE into the current info buffer.
 226 Use `guix-info-insert-ENTRY-TYPE-function' or
 227 `guix-info-insert-entry-default' if it is nil."
 228   (let* ((var (intern (concat "guix-info-insert-"
 229                               (symbol-name entry-type)
 230                               "-function")))
 231          (fun (symbol-value var)))
 232     (if (functionp fun)
 233         (funcall fun entry)
 234       (guix-info-insert-entry-default entry entry-type indent-level))))
 235
 236 (defun guix-info-insert-param (param entry entry-type)
 237   "Insert title and value of a PARAM at point.
 238 ENTRY is alist with parameters and their values.
 239 ENTRY-TYPE is a type of ENTRY."
 240   (let ((val (guix-assq-value entry param)))
 241     (unless (and guix-info-ignore-empty-vals (null val))
 242       (let* ((title          (guix-get-param-title entry-type param))
 243              (insert-methods (guix-info-get-insert-methods entry-type param))
 244              (val-method     (car insert-methods))
 245              (title-method   (cadr insert-methods)))
 246         (guix-info-method-funcall title title-method
 247                                   #'guix-info-insert-title-default)
 248         (guix-info-method-funcall val val-method
 249                                   #'guix-info-insert-val-default
 250                                   entry)
 251         (insert "\n")))))
 252
 253 (defun guix-info-method-funcall (val method default-fun &rest args)
 254   "Call METHOD or DEFAULT-FUN.
 255
 256 If METHOD is a function and VAL is non-nil, call this
 257 function by applying it to VAL and ARGS.
 258
 259 If METHOD is a face, propertize inserted VAL with this face."
 260   (cond ((or (null method)
 261              (facep method))
 262          (funcall default-fun val method))
 263         ((functionp method)
 264          (apply method val args))
 265         (t (error "Unknown method '%S'" method))))
 266
 267 (defun guix-info-insert-title-default (title &optional face format)
 268   "Insert TITLE formatted with `guix-info-param-title-format' at point."
 269   (guix-format-insert title
 270                       (or face 'guix-info-param-title)
 271                       (or format guix-info-param-title-format)))
 272
 273 (defun guix-info-insert-title-simple (title &optional face)
 274   "Insert TITLE at point."
 275   (guix-info-insert-title-default title face "%s:"))
 276
 277 (defun guix-info-insert-val-default (val &optional face)
 278   "Format and insert parameter value VAL at point.
 279
 280 This function is intended to be called after
 281 `guix-info-insert-title-default'.
 282
 283 If VAL is a one-line string longer than `guix-info-fill-column',
 284 split it into several short lines.  See also
 285 `guix-info-multiline-prefix'.
 286
 287 If FACE is non-nil, propertize inserted line(s) with this FACE."
 288   (guix-split-insert val face
 289                      guix-info-fill-column
 290                      (concat "\n" guix-info-multiline-prefix)))
 291
 292 (defun guix-info-insert-val-simple (val &optional face-or-fun)
 293   "Format and insert parameter value VAL at point.
 294
 295 This function is intended to be called after
 296 `guix-info-insert-title-simple'.
 297
 298 If VAL is a one-line string longer than `guix-info-fill-column',
 299 split it into several short lines and indent each line with
 300 `guix-info-indent' spaces.
 301
 302 If FACE-OR-FUN is a face, propertize inserted line(s) with this FACE.
 303
 304 If FACE-OR-FUN is a function, call it with VAL as argument.  If
 305 VAL is a list, call the function on each element of this list."
 306   (if (null val)
 307       (progn (guix-info-insert-indent)
 308              (guix-format-insert nil))
 309     (let ((prefix (concat "\n" (guix-info-get-indent))))
 310       (insert prefix)
 311       (if (functionp face-or-fun)
 312           (guix-mapinsert face-or-fun
 313                           (if (listp val) val (list val))
 314                           prefix)
 315         (guix-split-insert val face-or-fun
 316                            guix-info-fill-column prefix)))))
 317
 318 (defun guix-info-insert-time (seconds &optional _)
 319   "Insert formatted time string using SECONDS at point."
 320   (guix-info-insert-val-default (guix-get-time-string seconds)
 321                                 'guix-info-time))
 322
 323 \f
 324 ;;; Buttons
 325
 326 (defvar guix-info-button-map
 327   (let ((map (make-sparse-keymap)))
 328     (set-keymap-parent map button-map)
 329     (define-key map (kbd "c") 'guix-info-button-copy-label)
 330     map)
 331   "Keymap for buttons in info buffers.")
 332
 333 (define-button-type 'guix
 334   'keymap guix-info-button-map
 335   'follow-link t)
 336
 337 (define-button-type 'guix-action
 338   :supertype 'guix
 339   'face 'guix-info-action-button
 340   'mouse-face 'guix-info-action-button-mouse)
 341
 342 (define-button-type 'guix-file
 343   :supertype 'guix
 344   'face 'guix-info-file-path
 345   'help-echo "Find file"
 346   'action (lambda (btn)
 347             (guix-find-file (button-label btn))))
 348
 349 (define-button-type 'guix-url
 350   :supertype 'guix
 351   'face 'guix-info-url
 352   'help-echo "Browse URL"
 353   'action (lambda (btn)
 354             (browse-url (button-label btn))))
 355
 356 (define-button-type 'guix-package-location
 357   :supertype 'guix
 358   'face 'guix-package-info-location
 359   'help-echo "Find location of this package"
 360   'action (lambda (btn)
 361             (guix-find-location (button-label btn))))
 362
 363 (define-button-type 'guix-package-name
 364   :supertype 'guix
 365   'face 'guix-package-info-name-button
 366   'help-echo "Describe this package"
 367   'action (lambda (btn)
 368             (guix-get-show-entries guix-profile 'info guix-package-info-type
 369                                    'name (button-label btn))))
 370
 371 (defun guix-info-button-copy-label (&optional pos)
 372   "Copy a label of the button at POS into kill ring.
 373 If POS is nil, use the current point position."
 374   (interactive)
 375   (let ((button (button-at (or pos (point)))))
 376     (when button
 377       (kill-new (button-label button)))))
 378
 379 (defun guix-info-insert-action-button (label action &optional message
 380                                              &rest properties)
 381   "Make action button with LABEL and insert it at point.
 382 ACTION is a function called when the button is pressed.  It
 383 should accept button as the argument.
 384 MESSAGE is a button message.
 385 See `insert-text-button' for the meaning of PROPERTIES."
 386   (apply #'guix-insert-button
 387          label 'guix-action
 388          'action action
 389          'help-echo message
 390          properties))
 391
 392 (defun guix-info-insert-file-path (path &optional _)
 393   "Make button from file PATH and insert it at point."
 394   (guix-insert-button path 'guix-file))
 395
 396 (defun guix-info-insert-url (url &optional _)
 397   "Make button from URL and insert it at point."
 398   (guix-insert-button url 'guix-url))
 399
 400 \f
 401 (defvar guix-info-mode-map
 402   (let ((map (make-sparse-keymap)))
 403     (set-keymap-parent
 404      map (make-composed-keymap (list guix-root-map button-buffer-map)
 405                                special-mode-map))
 406     map)
 407   "Parent keymap for info buffers.")
 408
 409 (define-derived-mode guix-info-mode special-mode "Guix-Info"
 410   "Parent mode for displaying information in info buffers.")
 411
 412 \f
 413 ;;; Displaying packages
 414
 415 (guix-define-buffer-type info package
 416   :required (id installed non-unique))
 417
 418 (defface guix-package-info-heading
 419   '((((type tty pc) (class color)) :weight bold)
 420     (t :height 1.6 :weight bold :inherit variable-pitch))
 421   "Face for package name and version headings."
 422   :group 'guix-package-info-faces)
 423
 424 (defface guix-package-info-name
 425   '((t :inherit font-lock-keyword-face))
 426   "Face used for a name of a package."
 427   :group 'guix-package-info-faces)
 428
 429 (defface guix-package-info-name-button
 430   '((t :inherit button))
 431   "Face used for a full name that can be used to describe a package."
 432   :group 'guix-package-info-faces)
 433
 434 (defface guix-package-info-version
 435   '((t :inherit font-lock-builtin-face))
 436   "Face used for a version of a package."
 437   :group 'guix-package-info-faces)
 438
 439 (defface guix-package-info-synopsis
 440   '((((type tty pc) (class color)) :weight bold)
 441     (t :height 1.1 :weight bold :inherit variable-pitch))
 442   "Face used for a synopsis of a package."
 443   :group 'guix-package-info-faces)
 444
 445 (defface guix-package-info-description
 446   '((t))
 447   "Face used for a description of a package."
 448   :group 'guix-package-info-faces)
 449
 450 (defface guix-package-info-license
 451   '((t :inherit font-lock-string-face))
 452   "Face used for a license of a package."
 453   :group 'guix-package-info-faces)
 454
 455 (defface guix-package-info-location
 456   '((t :inherit link))
 457   "Face used for a location of a package."
 458   :group 'guix-package-info-faces)
 459
 460 (defface guix-package-info-installed-outputs
 461   '((default :weight bold)
 462     (((class color) (min-colors 88) (background light))
 463      :foreground "ForestGreen")
 464     (((class color) (min-colors 88) (background dark))
 465      :foreground "PaleGreen")
 466     (((class color) (min-colors 8))
 467      :foreground "green")
 468     (t :underline t))
 469   "Face used for installed outputs of a package."
 470   :group 'guix-package-info-faces)
 471
 472 (defface guix-package-info-uninstalled-outputs
 473   '((t :weight bold))
 474   "Face used for uninstalled outputs of a package."
 475   :group 'guix-package-info-faces)
 476
 477 (defface guix-package-info-obsolete
 478   '((t :inherit error))
 479   "Face used if a package is obsolete."
 480   :group 'guix-package-info-faces)
 481
 482 (defvar guix-info-insert-package-function
 483   #'guix-package-info-insert-with-heading
 484   "Function used to insert a package information.
 485 It is called with a single argument - alist of package parameters.
 486 If nil, insert package in a default way.")
 487
 488 (defvar guix-package-info-heading-params '(synopsis description)
 489   "List of parameters displayed in a heading along with name and version.")
 490
 491 (defcustom guix-package-info-fill-heading t
 492   "If nil, insert heading parameters in a raw form, without
 493 filling them to fit the window."
 494   :type 'boolean
 495   :group 'guix-package-info)
 496
 497 (defun guix-package-info-insert-heading (entry)
 498   "Insert the heading for package ENTRY.
 499 Show package name, version, and `guix-package-info-heading-params'."
 500   (guix-format-insert (concat (guix-assq-value entry 'name) " "
 501                               (guix-assq-value entry 'version))
 502                       'guix-package-info-heading)
 503   (insert "\n\n")
 504   (mapc (lambda (param)
 505           (let ((val  (guix-assq-value entry param))
 506                 (face (guix-get-symbol (symbol-name param)
 507                                        'info 'package)))
 508             (when val
 509               (let* ((col (min (window-width) fill-column))
 510                      (val (if guix-package-info-fill-heading
 511                               (guix-get-filled-string val col)
 512                             val)))
 513                 (guix-format-insert val (and (facep face) face))
 514                 (insert "\n\n")))))
 515         guix-package-info-heading-params))
 516
 517 (defun guix-package-info-insert-with-heading (entry)
 518   "Insert package ENTRY with its heading at point."
 519   (guix-package-info-insert-heading entry)
 520   (mapc (lambda (param)
 521           (unless (or (memq param '(name version))
 522                       (memq param guix-package-info-heading-params))
 523             (guix-info-insert-param param entry 'package)))
 524         (guix-info-get-displayed-params 'package)))
 525
 526 (defun guix-package-info-insert-description (desc &optional _)
 527   "Insert description DESC at point."
 528   (guix-info-insert-val-simple desc 'guix-package-info-description))
 529
 530 (defun guix-package-info-insert-location (location &optional _)
 531   "Make button from file LOCATION and insert it at point."
 532   (guix-insert-button location 'guix-package-location))
 533
 534 (defmacro guix-package-info-define-insert-inputs (&optional type)
 535   "Define a face and a function for inserting package inputs.
 536 TYPE is a type of inputs.
 537 Function name is `guix-package-info-insert-TYPE-inputs'.
 538 Face name is `guix-package-info-TYPE-inputs'."
 539   (let* ((type-str (symbol-name type))
 540          (type-name (and type (concat type-str "-")))
 541          (type-desc (and type (concat type-str " ")))
 542          (face (intern (concat "guix-package-info-" type-name "inputs")))
 543          (btn  (intern (concat "guix-package-" type-name "input")))
 544          (fun  (intern (concat "guix-package-info-insert-" type-name "inputs"))))
 545     `(progn
 546        (defface ,face
 547          '((t :inherit guix-package-info-name-button))
 548          ,(concat "Face used for " type-desc "inputs of a package.")
 549          :group 'guix-package-info-faces)
 550
 551        (define-button-type ',btn
 552          :supertype 'guix-package-name
 553          'face ',face)
 554
 555        (defun ,fun (inputs &optional _)
 556          ,(concat "Make buttons from " type-desc "INPUTS and insert them at point.")
 557          (guix-package-info-insert-full-names inputs ',btn)))))
 558
 559 (guix-package-info-define-insert-inputs)
 560 (guix-package-info-define-insert-inputs native)
 561 (guix-package-info-define-insert-inputs propagated)
 562
 563 (defun guix-package-info-insert-full-names (names button-type)
 564   "Make BUTTON-TYPE buttons from package NAMES and insert them at point.
 565 NAMES is a list of strings."
 566   (if names
 567       (guix-info-insert-val-default
 568        (with-temp-buffer
 569          (guix-mapinsert (lambda (name)
 570                            (guix-insert-button name button-type))
 571                          names
 572                          guix-list-separator)
 573          (buffer-substring (point-min) (point-max))))
 574     (guix-format-insert nil)))
 575
 576 \f
 577 ;;; Inserting outputs and installed parameters
 578
 579 (defvar guix-package-info-output-format "%-10s"
 580   "String used to format output names of the packages.
 581 It should be a '%s'-sequence.  After inserting an output name
 582 formatted with this string, an action button is inserted.")
 583
 584 (defvar guix-package-info-obsolete-string "(This package is obsolete)"
 585   "String used if a package is obsolete.")
 586
 587 (defvar guix-info-insert-installed-function nil
 588   "Function used to insert an installed information.
 589 It is called with a single argument - alist of installed
 590 parameters (`output', `path', `dependencies').
 591 If nil, insert installed info in a default way.")
 592
 593 (defun guix-package-info-insert-outputs (outputs entry)
 594   "Insert OUTPUTS from package ENTRY at point."
 595   (and (guix-assq-value entry 'obsolete)
 596        (guix-package-info-insert-obsolete-text))
 597   (and (guix-assq-value entry 'non-unique)
 598        (guix-assq-value entry 'installed)
 599        (guix-package-info-insert-non-unique-text
 600         (guix-get-full-name entry)))
 601   (insert "\n")
 602   (mapc (lambda (output)
 603           (guix-package-info-insert-output output entry))
 604         outputs))
 605
 606 (defun guix-package-info-insert-obsolete-text ()
 607   "Insert a message about obsolete package at point."
 608   (guix-info-insert-indent)
 609   (guix-format-insert guix-package-info-obsolete-string
 610                       'guix-package-info-obsolete))
 611
 612 (defun guix-package-info-insert-non-unique-text (full-name)
 613   "Insert a message about non-unique package with FULL-NAME at point."
 614   (insert "\n")
 615   (guix-info-insert-indent)
 616   (insert "Installed outputs are displayed for a non-unique ")
 617   (guix-insert-button full-name 'guix-package-name)
 618   (insert " package."))
 619
 620 (defun guix-package-info-insert-output (output entry)
 621   "Insert OUTPUT at point.
 622 Make some fancy text with buttons and additional stuff if the
 623 current OUTPUT is installed (if there is such output in
 624 `installed' parameter of a package ENTRY)."
 625   (let* ((installed (guix-assq-value entry 'installed))
 626          (obsolete  (guix-assq-value entry 'obsolete))
 627          (installed-entry (cl-find-if
 628                            (lambda (entry)
 629                              (string= (guix-assq-value entry 'output)
 630                                       output))
 631                            installed))
 632          (action-type (if installed-entry 'delete 'install)))
 633     (guix-info-insert-indent)
 634     (guix-format-insert output
 635                         (if installed-entry
 636                             'guix-package-info-installed-outputs
 637                           'guix-package-info-uninstalled-outputs)
 638                         guix-package-info-output-format)
 639     (guix-package-info-insert-action-button action-type entry output)
 640     (when obsolete
 641       (guix-info-insert-indent)
 642       (guix-package-info-insert-action-button 'upgrade entry output))
 643     (insert "\n")
 644     (when installed-entry
 645       (guix-info-insert-entry installed-entry 'installed 2))))
 646
 647 (defun guix-package-info-insert-action-button (type entry output)
 648   "Insert button to process an action on a package OUTPUT at point.
 649 TYPE is one of the following symbols: `install', `delete', `upgrade'.
 650 ENTRY is an alist with package info."
 651   (let ((type-str (capitalize (symbol-name type)))
 652         (full-name (guix-get-full-name entry output)))
 653     (guix-info-insert-action-button
 654      type-str
 655      (lambda (btn)
 656        (guix-process-package-actions
 657         guix-profile
 658         `((,(button-get btn 'action-type) (,(button-get btn 'id)
 659                                            ,(button-get btn 'output))))
 660         (current-buffer)))
 661      (concat type-str " '" full-name "'")
 662      'action-type type
 663      'id (or (guix-assq-value entry 'package-id)
 664              (guix-assq-value entry 'id))
 665      'output output)))
 666
 667 (defun guix-package-info-insert-output-path (path &optional _)
 668   "Insert PATH of the installed output."
 669   (guix-info-insert-val-simple path #'guix-info-insert-file-path))
 670
 671 (defalias 'guix-package-info-insert-output-dependencies
 672   'guix-package-info-insert-output-path)
 673
 674 \f
 675 ;;; Inserting a source
 676
 677 (defface guix-package-info-source
 678   '((t :inherit link :underline nil))
 679   "Face used for a source URL of a package."
 680   :group 'guix-package-info-faces)
 681
 682 (defcustom guix-package-info-auto-find-source nil
 683   "If non-nil, find a source file after pressing a \"Show\" button.
 684 If nil, just display the source file path without finding."
 685   :type 'boolean
 686   :group 'guix-package-info)
 687
 688 (defcustom guix-package-info-auto-download-source t
 689   "If nil, do not automatically download a source file if it doesn't exist.
 690 After pressing a \"Show\" button, a derivation of the package
 691 source is calculated and a store file path is displayed.  If this
 692 variable is non-nil and the source file does not exist in the
 693 store, it will be automatically downloaded (with a possible
 694 prompt depending on `guix-operation-confirm' variable)."
 695   :type 'boolean
 696   :group 'guix-package-info)
 697
 698 (defvar guix-package-info-download-buffer nil
 699   "Buffer from which a current download operation was performed.")
 700
 701 (define-button-type 'guix-package-source
 702   :supertype 'guix
 703   'face 'guix-package-info-source
 704   'help-echo ""
 705   'action (lambda (_)
 706             ;; As a source may not be a real URL (e.g., "mirror://..."),
 707             ;; no action is bound to a source button.
 708             (message "Yes, this is the source URL. What did you expect?")))
 709
 710 (defun guix-package-info-insert-source-url (url &optional _)
 711   "Make button from source URL and insert it at point."
 712   (guix-insert-button url 'guix-package-source))
 713
 714 (defun guix-package-info-show-source (entry-id package-id)
 715   "Show file name of a package source in the current info buffer.
 716 Find the file if needed (see `guix-package-info-auto-find-source').
 717 ENTRY-ID is an ID of the current entry (package or output).
 718 PACKAGE-ID is an ID of the package which source to show."
 719   (let* ((entry (guix-get-entry-by-id entry-id guix-entries))
 720          (file  (guix-package-source-path package-id)))
 721     (or file
 722         (error "Couldn't define file path of the package source"))
 723     (let* ((new-entry (cons (cons 'source-file file)
 724                             entry))
 725            (entries (cl-substitute-if
 726                      new-entry
 727                      (lambda (entry)
 728                        (equal (guix-assq-value entry 'id)
 729                               entry-id))
 730                      guix-entries
 731                      :count 1)))
 732       (guix-redisplay-buffer :entries entries)
 733       (if (file-exists-p file)
 734           (if guix-package-info-auto-find-source
 735               (guix-find-file file)
 736             (message "The source store path is displayed."))
 737         (if guix-package-info-auto-download-source
 738             (guix-package-info-download-source package-id)
 739           (message "The source does not exist in the store."))))))
 740
 741 (defun guix-package-info-download-source (package-id)
 742   "Download a source of the package PACKAGE-ID."
 743   (setq guix-package-info-download-buffer (current-buffer))
 744   (guix-package-source-build-derivation
 745    package-id
 746    "The source does not exist in the store. Download it?"))
 747
 748 (defun guix-package-info-insert-source (source entry)
 749   "Insert SOURCE from package ENTRY at point.
 750 SOURCE is a list of URLs."
 751   (guix-info-insert-indent)
 752   (if (null source)
 753       (guix-format-insert nil)
 754     (let* ((source-file (guix-assq-value entry 'source-file))
 755            (entry-id    (guix-assq-value entry 'id))
 756            (package-id  (or (guix-assq-value entry 'package-id)
 757                             entry-id)))
 758       (if (null source-file)
 759           (guix-info-insert-action-button
 760            "Show"
 761            (lambda (btn)
 762              (guix-package-info-show-source (button-get btn 'entry-id)
 763                                             (button-get btn 'package-id)))
 764            "Show the source store path of the current package"
 765            'entry-id entry-id
 766            'package-id package-id)
 767         (unless (file-exists-p source-file)
 768           (guix-info-insert-action-button
 769            "Download"
 770            (lambda (btn)
 771              (guix-package-info-download-source
 772               (button-get btn 'package-id)))
 773            "Download the source into the store"
 774            'package-id package-id))
 775         (guix-info-insert-val-simple source-file
 776                                      #'guix-info-insert-file-path))
 777       (guix-info-insert-val-simple source
 778                                    #'guix-package-info-insert-source-url))))
 779
 780 (defun guix-package-info-redisplay-after-download ()
 781   "Redisplay an 'info' buffer after downloading the package source.
 782 This function is used to hide a \"Download\" button if needed."
 783   (when (buffer-live-p guix-package-info-download-buffer)
 784     (guix-redisplay-buffer :buffer guix-package-info-download-buffer)
 785     (setq guix-package-info-download-buffer nil)))
 786
 787 (add-hook 'guix-after-source-download-hook
 788           'guix-package-info-redisplay-after-download)
 789
 790 \f
 791 ;;; Displaying outputs
 792
 793 (guix-define-buffer-type info output
 794   :buffer-name "*Guix Package Info*"
 795   :required (id package-id installed non-unique))
 796
 797 (defvar guix-info-insert-output-function nil
 798   "Function used to insert an output information.
 799 It is called with a single argument - alist of output parameters.
 800 If nil, insert output in a default way.")
 801
 802 (defun guix-output-info-insert-version (version entry)
 803   "Insert output VERSION and obsolete text if needed at point."
 804   (guix-info-insert-val-default version
 805                                 'guix-package-info-version)
 806   (and (guix-assq-value entry 'obsolete)
 807        (guix-package-info-insert-obsolete-text)))
 808
 809 (defun guix-output-info-insert-output (output entry)
 810   "Insert OUTPUT and action buttons at point."
 811   (let* ((installed (guix-assq-value entry 'installed))
 812          (obsolete  (guix-assq-value entry 'obsolete))
 813          (action-type (if installed 'delete 'install)))
 814     (guix-info-insert-val-default
 815      output
 816      (if installed
 817          'guix-package-info-installed-outputs
 818        'guix-package-info-uninstalled-outputs))
 819     (guix-info-insert-indent)
 820     (guix-package-info-insert-action-button action-type entry output)
 821     (when obsolete
 822       (guix-info-insert-indent)
 823       (guix-package-info-insert-action-button 'upgrade entry output))))
 824
 825 \f
 826 ;;; Displaying generations
 827
 828 (guix-define-buffer-type info generation)
 829
 830 (defface guix-generation-info-number
 831   '((t :inherit font-lock-keyword-face))
 832   "Face used for a number of a generation."
 833   :group 'guix-generation-info-faces)
 834
 835 (defface guix-generation-info-current
 836   '((t :inherit guix-package-info-installed-outputs))
 837   "Face used if a generation is the current one."
 838   :group 'guix-generation-info-faces)
 839
 840 (defface guix-generation-info-not-current
 841   '((t nil))
 842   "Face used if a generation is not the current one."
 843   :group 'guix-generation-info-faces)
 844
 845 (defvar guix-info-insert-generation-function nil
 846   "Function used to insert a generation information.
 847 It is called with a single argument - alist of generation parameters.
 848 If nil, insert generation in a default way.")
 849
 850 (defun guix-generation-info-insert-number (number &optional _)
 851   "Insert generation NUMBER and action buttons."
 852   (guix-info-insert-val-default number 'guix-generation-info-number)
 853   (guix-info-insert-indent)
 854   (guix-info-insert-action-button
 855    "Packages"
 856    (lambda (btn)
 857      (guix-get-show-entries guix-profile 'list guix-package-list-type
 858                             'generation (button-get btn 'number)))
 859    "Show installed packages for this generation"
 860    'number number)
 861   (guix-info-insert-indent)
 862   (guix-info-insert-action-button
 863    "Delete"
 864    (lambda (btn)
 865      (guix-delete-generations guix-profile (list (button-get btn 'number))
 866                               (current-buffer)))
 867    "Delete this generation"
 868    'number number))
 869
 870 (defun guix-generation-info-insert-current (val entry)
 871   "Insert boolean value VAL showing whether this generation is current."
 872   (if val
 873       (guix-info-insert-val-default "Yes" 'guix-generation-info-current)
 874     (guix-info-insert-val-default "No" 'guix-generation-info-not-current)
 875     (guix-info-insert-indent)
 876     (guix-info-insert-action-button
 877      "Switch"
 878      (lambda (btn)
 879        (guix-switch-to-generation guix-profile (button-get btn 'number)
 880                                   (current-buffer)))
 881      "Switch to this generation (make it the current one)"
 882      'number (guix-assq-value entry 'number))))
 883
 884 (provide 'guix-info)
 885
 886 ;;; guix-info.el ends here