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