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