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