emacs/guix-base.el

   1 ;;; guix-base.el --- Common definitions   -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com>
   4
   5 ;; This file is part of GNU Guix.
   6
   7 ;; GNU Guix is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Guix is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This file provides some base and common definitions for guix.el
  23 ;; package.
  24
  25 ;; List and info buffers have many common patterns that are defined
  26 ;; using `guix-define-buffer-type' macro from this file.
  27
  28 ;;; Code:
  29
  30 (require 'cl-lib)
  31 (require 'guix-profiles)
  32 (require 'guix-backend)
  33 (require 'guix-guile)
  34 (require 'guix-utils)
  35 (require 'guix-history)
  36 (require 'guix-messages)
  37
  38 \f
  39 ;;; Parameters of the entries
  40
  41 (defvar guix-param-titles
  42   '((package
  43      (id                . "ID")
  44      (name              . "Name")
  45      (version           . "Version")
  46      (source            . "Source")
  47      (license           . "License")
  48      (synopsis          . "Synopsis")
  49      (description       . "Description")
  50      (home-url          . "Home page")
  51      (outputs           . "Outputs")
  52      (inputs            . "Inputs")
  53      (native-inputs     . "Native inputs")
  54      (propagated-inputs . "Propagated inputs")
  55      (location          . "Location")
  56      (installed         . "Installed"))
  57     (installed
  58      (path              . "Installed path")
  59      (dependencies      . "Dependencies")
  60      (output            . "Output"))
  61     (output
  62      (id                . "ID")
  63      (name              . "Name")
  64      (version           . "Version")
  65      (source            . "Source")
  66      (license           . "License")
  67      (synopsis          . "Synopsis")
  68      (description       . "Description")
  69      (home-url          . "Home page")
  70      (output            . "Output")
  71      (inputs            . "Inputs")
  72      (native-inputs     . "Native inputs")
  73      (propagated-inputs . "Propagated inputs")
  74      (location          . "Location")
  75      (installed         . "Installed")
  76      (path              . "Installed path")
  77      (dependencies      . "Dependencies"))
  78     (generation
  79      (id                . "ID")
  80      (number            . "Number")
  81      (prev-number       . "Previous number")
  82      (current           . "Current")
  83      (path              . "Path")
  84      (time              . "Time")))
  85   "List for defining titles of entry parameters.
  86 Titles are used for displaying information about entries.
  87 Each element of the list has a form:
  88
  89   (ENTRY-TYPE . ((PARAM . TITLE) ...))")
  90
  91 (defun guix-get-param-title (entry-type param)
  92   "Return title of an ENTRY-TYPE entry parameter PARAM."
  93   (or (guix-assq-value guix-param-titles
  94                        entry-type param)
  95       (prog1 (symbol-name param)
  96         (message "Couldn't find title for '%S %S'."
  97                  entry-type param))))
  98
  99 (defun guix-get-name-spec (name version &optional output)
 100   "Return Guix package specification by its NAME, VERSION and OUTPUT."
 101   (concat name "-" version
 102           (when output (concat ":" output))))
 103
 104 (defun guix-get-full-name (entry &optional output)
 105   "Return name specification of the package ENTRY and OUTPUT."
 106   (guix-get-name-spec (guix-assq-value entry 'name)
 107                       (guix-assq-value entry 'version)
 108                       output))
 109
 110 (defun guix-entry-to-specification (entry)
 111   "Return name specification by the package or output ENTRY."
 112   (guix-get-name-spec (guix-assq-value entry 'name)
 113                       (guix-assq-value entry 'version)
 114                       (guix-assq-value entry 'output)))
 115
 116 (defun guix-entries-to-specifications (entries)
 117   "Return name specifications by the package or output ENTRIES."
 118   (cl-remove-duplicates (mapcar #'guix-entry-to-specification entries)
 119                         :test #'string=))
 120
 121 (defun guix-get-installed-outputs (entry)
 122   "Return list of installed outputs for the package ENTRY."
 123   (mapcar (lambda (installed-entry)
 124             (guix-assq-value installed-entry 'output))
 125           (guix-assq-value entry 'installed)))
 126
 127 (defun guix-get-entry-by-id (id entries)
 128   "Return entry from ENTRIES by entry ID."
 129   (cl-find-if (lambda (entry)
 130                 (equal id (guix-assq-value entry 'id)))
 131               entries))
 132
 133 (defun guix-get-package-id-and-output-by-output-id (oid)
 134   "Return list (PACKAGE-ID OUTPUT) by output id OID."
 135   (cl-multiple-value-bind (pid-str output)
 136       (split-string oid ":")
 137     (let ((pid (string-to-number pid-str)))
 138       (list (if (= 0 pid) pid-str pid)
 139             output))))
 140
 141 \f
 142 ;;; Location of the packages
 143
 144 (defvar guix-directory nil
 145   "Default Guix directory.
 146 If it is not set by a user, it is set after starting Guile REPL.
 147 This directory is used to define location of the packages.")
 148
 149 (defun guix-set-directory ()
 150   "Set `guix-directory' if needed."
 151   (or guix-directory
 152       (setq guix-directory
 153             (guix-eval-read "%guix-dir"))))
 154
 155 (add-hook 'guix-after-start-repl-hook 'guix-set-directory)
 156
 157 (defun guix-find-location (location)
 158   "Go to LOCATION of a package.
 159 LOCATION is a string of the form:
 160
 161   \"PATH:LINE:COLUMN\"
 162
 163 If PATH is relative, it is considered to be relative to
 164 `guix-directory'."
 165   (cl-multiple-value-bind (path line col)
 166       (split-string location ":")
 167     (let ((file (expand-file-name path guix-directory))
 168           (line (string-to-number line))
 169           (col  (string-to-number col)))
 170       (find-file file)
 171       (goto-char (point-min))
 172       (forward-line (- line 1))
 173       (move-to-column col)
 174       (recenter 1))))
 175
 176 (defun guix-package-location (id-or-name)
 177   "Return location of a package with ID-OR-NAME.
 178 For the meaning of location, see `guix-find-location'."
 179   (guix-eval-read (guix-make-guile-expression
 180                    'package-location-string id-or-name)))
 181
 182 \f
 183 ;;; Receivable lists of packages, lint checkers, etc.
 184
 185 (guix-memoized-defun guix-graph-type-names ()
 186   "Return a list of names of available graph node types."
 187   (guix-eval-read (guix-make-guile-expression 'graph-type-names)))
 188
 189 (guix-memoized-defun guix-refresh-updater-names ()
 190   "Return a list of names of available refresh updater types."
 191   (guix-eval-read (guix-make-guile-expression 'refresh-updater-names)))
 192
 193 (guix-memoized-defun guix-lint-checker-names ()
 194   "Return a list of names of available lint checkers."
 195   (guix-eval-read (guix-make-guile-expression 'lint-checker-names)))
 196
 197 (guix-memoized-defun guix-package-names ()
 198   "Return a list of names of available packages."
 199   (sort
 200    ;; Work around <https://github.com/jaor/geiser/issues/64>:
 201    ;; list of strings is parsed much slower than list of lists,
 202    ;; so we use 'package-names-lists' instead of 'package-names'.
 203
 204    ;; (guix-eval-read (guix-make-guile-expression 'package-names))
 205
 206    (mapcar #'car
 207            (guix-eval-read (guix-make-guile-expression
 208                             'package-names-lists)))
 209    #'string<))
 210
 211 \f
 212 ;;; Buffers and auto updating.
 213
 214 (defcustom guix-update-after-operation 'current
 215   "Define what information to update after executing an operation.
 216
 217 After successful executing an operation in the Guix REPL (for
 218 example after installing a package), information in Guix buffers
 219 will or will not be automatically updated depending on a value of
 220 this variable.
 221
 222 If nil, update nothing (do not revert any buffer).
 223 If `current', update the buffer from which an operation was performed.
 224 If `all', update all Guix buffers (not recommended)."
 225   :type '(choice (const :tag "Do nothing" nil)
 226                  (const :tag "Update operation buffer" current)
 227                  (const :tag "Update all Guix buffers" all))
 228   :group 'guix)
 229
 230 (defcustom guix-buffer-name-function #'guix-buffer-name-default
 231   "Function used to define name of a buffer for displaying information.
 232 The function is called with 4 arguments: PROFILE, BUFFER-TYPE,
 233 ENTRY-TYPE, SEARCH-TYPE.  See `guix-get-entries' for the meaning
 234 of the arguments."
 235   :type '(choice (function-item guix-buffer-name-default)
 236                  (function-item guix-buffer-name-simple)
 237                  (function :tag "Other function"))
 238   :group 'guix)
 239
 240 (defun guix-buffer-name-simple (_profile buffer-type entry-type
 241                                 &optional _search-type)
 242   "Return name of a buffer used for displaying information.
 243 The name is defined by `guix-ENTRY-TYPE-BUFFER-TYPE-buffer-name'
 244 variable."
 245   (symbol-value
 246    (guix-get-symbol "buffer-name" buffer-type entry-type)))
 247
 248 (defun guix-buffer-name-default (profile buffer-type entry-type
 249                                  &optional _search-type)
 250   "Return name of a buffer used for displaying information.
 251 The name is almost the same as the one defined by
 252 `guix-buffer-name-simple' except the PROFILE name is added to it."
 253   (let ((simple-name (guix-buffer-name-simple
 254                       profile buffer-type entry-type))
 255         (profile-name (file-name-base (directory-file-name profile)))
 256         (re (rx string-start
 257                 (group (? "*"))
 258                 (group (*? any))
 259                 (group (? "*"))
 260                 string-end)))
 261     (or (string-match re simple-name)
 262         (error "Unexpected error in defining guix buffer name"))
 263     (let ((first*    (match-string 1 simple-name))
 264           (name-body (match-string 2 simple-name))
 265           (last*     (match-string 3 simple-name)))
 266       ;; Handle the case when buffer name is wrapped by '*'.
 267       (if (and (string= "*" first*)
 268                (string= "*" last*))
 269           (concat "*" name-body ": " profile-name "*")
 270         (concat simple-name ": " profile-name)))))
 271
 272 (defun guix-buffer-name (profile buffer-type entry-type search-type)
 273   "Return name of a buffer used for displaying information.
 274 See `guix-buffer-name-function' for details."
 275   (let ((fun (if (functionp guix-buffer-name-function)
 276                  guix-buffer-name-function
 277                #'guix-buffer-name-default)))
 278     (funcall fun profile buffer-type entry-type search-type)))
 279
 280 (defun guix-switch-to-buffer (buffer)
 281   "Switch to a 'list' or 'info' BUFFER."
 282   (pop-to-buffer buffer
 283                  '((display-buffer-reuse-window
 284                     display-buffer-same-window))))
 285
 286 (defun guix-buffer-p (&optional buffer modes)
 287   "Return non-nil if BUFFER mode is derived from any of the MODES.
 288 If BUFFER is nil, check current buffer.
 289 If MODES is nil, use `guix-list-mode' and `guix-info-mode'."
 290   (with-current-buffer (or buffer (current-buffer))
 291     (apply #'derived-mode-p
 292            (or modes
 293                '(guix-list-mode guix-info-mode)))))
 294
 295 (defun guix-buffers (&optional modes)
 296   "Return list of all buffers with major modes derived from MODES.
 297 If MODES is nil, return list of all Guix 'list' and 'info' buffers."
 298   (cl-remove-if-not (lambda (buf)
 299                       (guix-buffer-p buf modes))
 300                     (buffer-list)))
 301
 302 (defun guix-update-buffer (buffer)
 303   "Update information in a 'list' or 'info' BUFFER."
 304   (with-current-buffer buffer
 305     (guix-revert-buffer nil t)))
 306
 307 (defun guix-update-buffers-maybe-after-operation ()
 308   "Update buffers after Guix operation if needed.
 309 See `guix-update-after-operation' for details."
 310   (let ((to-update
 311          (and guix-operation-buffer
 312               (cl-case guix-update-after-operation
 313                 (current (and (buffer-live-p guix-operation-buffer)
 314                               (guix-buffer-p guix-operation-buffer)
 315                               (list guix-operation-buffer)))
 316                 (all     (guix-buffers))))))
 317     (setq guix-operation-buffer nil)
 318     (mapc #'guix-update-buffer to-update)))
 319
 320 (add-hook 'guix-after-repl-operation-hook
 321           'guix-update-buffers-maybe-after-operation)
 322
 323 \f
 324 ;;; Common definitions for buffer types
 325
 326 (defvar guix-root-map
 327   (let ((map (make-sparse-keymap)))
 328     (define-key map (kbd "l") 'guix-history-back)
 329     (define-key map (kbd "r") 'guix-history-forward)
 330     (define-key map (kbd "g") 'revert-buffer)
 331     (define-key map (kbd "R") 'guix-redisplay-buffer)
 332     (define-key map (kbd "M") 'guix-apply-manifest)
 333     (define-key map (kbd "C-c C-z") 'guix-switch-to-repl)
 334     map)
 335   "Parent keymap for all guix modes.")
 336
 337 (defvar-local guix-profile nil
 338   "Profile used for the current buffer.")
 339 (put 'guix-profile 'permanent-local t)
 340
 341 (defvar-local guix-entries nil
 342   "List of the currently displayed entries.
 343 Each element of the list is alist with entry info of the
 344 following form:
 345
 346   ((PARAM . VAL) ...)
 347
 348 PARAM is a name of the entry parameter.
 349 VAL is a value of this parameter.")
 350 (put 'guix-entries 'permanent-local t)
 351
 352 (defvar-local guix-buffer-type nil
 353   "Type of the current buffer.")
 354 (put 'guix-buffer-type 'permanent-local t)
 355
 356 (defvar-local guix-entry-type nil
 357   "Type of the current entry.")
 358 (put 'guix-entry-type 'permanent-local t)
 359
 360 (defvar-local guix-search-type nil
 361   "Type of the current search.")
 362 (put 'guix-search-type 'permanent-local t)
 363
 364 (defvar-local guix-search-vals nil
 365   "Values of the current search.")
 366 (put 'guix-search-vals 'permanent-local t)
 367
 368 (defsubst guix-set-vars (profile entries buffer-type entry-type
 369                          search-type search-vals)
 370   "Set local variables for the current Guix buffer."
 371   (setq default-directory profile
 372         guix-profile      profile
 373         guix-entries      entries
 374         guix-buffer-type  buffer-type
 375         guix-entry-type   entry-type
 376         guix-search-type  search-type
 377         guix-search-vals  search-vals))
 378
 379 (defun guix-get-symbol (postfix buffer-type &optional entry-type)
 380   (intern (concat "guix-"
 381                   (when entry-type
 382                     (concat (symbol-name entry-type) "-"))
 383                   (symbol-name buffer-type) "-" postfix)))
 384
 385 (defmacro guix-define-buffer-type (buf-type entry-type &rest args)
 386   "Define common for BUF-TYPE buffers for displaying ENTRY-TYPE entries.
 387
 388 In the text below TYPE means ENTRY-TYPE-BUF-TYPE.
 389
 390 This macro defines `guix-TYPE-mode', a custom group and several
 391 user variables.
 392
 393 The following stuff should be defined outside this macro:
 394
 395   - `guix-BUF-TYPE-mode' - parent mode for the defined mode.
 396
 397   - `guix-TYPE-mode-initialize' (optional) - function for
 398   additional mode settings; it is called without arguments.
 399
 400 Remaining argument (ARGS) should have a form [KEYWORD VALUE] ...  The
 401 following keywords are available:
 402
 403   - `:buffer-name' - default value for the defined
 404     `guix-TYPE-buffer-name' variable.
 405
 406   - `:required' - default value for the defined
 407     `guix-TYPE-required-params' variable.
 408
 409   - `:history-size' - default value for the defined
 410     `guix-TYPE-history-size' variable.
 411
 412   - `:revert' - default value for the defined
 413     `guix-TYPE-revert-no-confirm' variable."
 414   (let* ((entry-type-str (symbol-name entry-type))
 415          (buf-type-str   (symbol-name buf-type))
 416          (Entry-type-str (capitalize entry-type-str))
 417          (Buf-type-str   (capitalize buf-type-str))
 418          (entry-str      (concat entry-type-str " entries"))
 419          (buf-str        (concat buf-type-str " buffer"))
 420          (prefix         (concat "guix-" entry-type-str "-" buf-type-str))
 421          (group          (intern prefix))
 422          (faces-group    (intern (concat prefix "-faces")))
 423          (mode-map-str   (concat prefix "-mode-map"))
 424          (parent-mode    (intern (concat "guix-" buf-type-str "-mode")))
 425          (mode           (intern (concat prefix "-mode")))
 426          (mode-init-fun  (intern (concat prefix "-mode-initialize")))
 427          (buf-name-var   (intern (concat prefix "-buffer-name")))
 428          (revert-var     (intern (concat prefix "-revert-no-confirm")))
 429          (history-var    (intern (concat prefix "-history-size")))
 430          (params-var     (intern (concat prefix "-required-params")))
 431          (buf-name-val   (format "*Guix %s %s*" Entry-type-str Buf-type-str))
 432          (revert-val     nil)
 433          (history-val    20)
 434          (params-val     '(id)))
 435
 436     ;; Process the keyword args.
 437     (while (keywordp (car args))
 438       (pcase (pop args)
 439         (`:required     (setq params-val (pop args)))
 440         (`:history-size (setq history-val (pop args)))
 441         (`:revert       (setq revert-val (pop args)))
 442         (`:buffer-name  (setq buf-name-val (pop args)))
 443         (_ (pop args))))
 444
 445     `(progn
 446        (defgroup ,group nil
 447          ,(concat Buf-type-str " buffer with " entry-str ".")
 448          :prefix ,(concat prefix "-")
 449          :group ',(intern (concat "guix-" buf-type-str)))
 450
 451        (defgroup ,faces-group nil
 452          ,(concat "Faces for " buf-type-str " buffer with " entry-str ".")
 453          :group ',(intern (concat "guix-" buf-type-str "-faces")))
 454
 455        (defcustom ,buf-name-var ,buf-name-val
 456          ,(concat "Default name of the " buf-str " for displaying " entry-str ".")
 457          :type 'string
 458          :group ',group)
 459
 460        (defcustom ,history-var ,history-val
 461          ,(concat "Maximum number of items saved in the history of the " buf-str ".\n"
 462                   "If 0, the history is disabled.")
 463          :type 'integer
 464          :group ',group)
 465
 466        (defcustom ,revert-var ,revert-val
 467          ,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".")
 468          :type 'boolean
 469          :group ',group)
 470
 471        (defvar ,params-var ',params-val
 472          ,(concat "List of required " entry-type-str " parameters.\n\n"
 473                   "Displayed parameters and parameters from this list are received\n"
 474                   "for each " entry-type-str ".\n\n"
 475                   "May be a special value `all', in which case all supported\n"
 476                   "parameters are received (this may be very slow for a big number\n"
 477                   "of entries).\n\n"
 478                   "Do not remove `id' from this list as it is required for\n"
 479                   "identifying an entry."))
 480
 481        (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str)
 482          ,(concat "Major mode for displaying information about " entry-str ".\n\n"
 483                   "\\{" mode-map-str "}")
 484          (setq-local revert-buffer-function 'guix-revert-buffer)
 485          (setq-local guix-history-size ,history-var)
 486          (and (fboundp ',mode-init-fun) (,mode-init-fun))))))
 487
 488 (put 'guix-define-buffer-type 'lisp-indent-function 'defun)
 489
 490 \f
 491 ;;; Getting and displaying info about packages and generations
 492
 493 (defcustom guix-package-list-type 'output
 494   "Define how to display packages in a list buffer.
 495 May be a symbol `package' or `output' (if `output', display each
 496 output on a separate line; if `package', display each package on
 497 a separate line)."
 498   :type '(choice (const :tag "List of packages" package)
 499                  (const :tag "List of outputs" output))
 500   :group 'guix)
 501
 502 (defcustom guix-package-info-type 'package
 503   "Define how to display packages in an info buffer.
 504 May be a symbol `package' or `output' (if `output', display each
 505 output separately; if `package', display outputs inside a package
 506 information)."
 507   :type '(choice (const :tag "Display packages" package)
 508                  (const :tag "Display outputs" output))
 509   :group 'guix)
 510
 511 (defun guix-get-entries (profile entry-type search-type search-vals
 512                          &optional params)
 513   "Search for entries of ENTRY-TYPE.
 514
 515 Call an appropriate scheme function and return a list of the
 516 form of `guix-entries'.
 517
 518 ENTRY-TYPE should be one of the following symbols: `package',
 519 `output' or `generation'.
 520
 521 SEARCH-TYPE may be one of the following symbols:
 522
 523 - If ENTRY-TYPE is `package' or `output': `id', `name', `regexp',
 524   `all-available', `newest-available', `installed', `obsolete',
 525   `generation'.
 526
 527 - If ENTRY-TYPE is `generation': `id', `last', `all', `time'.
 528
 529 PARAMS is a list of parameters for receiving.  If nil, get
 530 information with all available parameters."
 531   (guix-eval-read (guix-make-guile-expression
 532                    'entries
 533                    profile params entry-type search-type search-vals)))
 534
 535 (defun guix-get-show-entries (profile buffer-type entry-type search-type
 536                               &rest search-vals)
 537   "Search for ENTRY-TYPE entries and show results in BUFFER-TYPE buffer.
 538 See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS."
 539   (let ((entries (guix-get-entries profile entry-type search-type search-vals
 540                                    (guix-get-params-for-receiving
 541                                     buffer-type entry-type))))
 542     (guix-set-buffer profile entries buffer-type entry-type
 543                      search-type search-vals)))
 544
 545 (defun guix-set-buffer (profile entries buffer-type entry-type search-type
 546                         search-vals &optional history-replace no-display)
 547   "Set up BUFFER-TYPE buffer for displaying ENTRY-TYPE ENTRIES.
 548
 549 Insert ENTRIES in buffer, set variables and make history item.
 550 ENTRIES should have a form of `guix-entries'.
 551
 552 See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS.
 553
 554 If HISTORY-REPLACE is non-nil, replace current history item,
 555 otherwise add the new one.
 556
 557 If NO-DISPLAY is non-nil, do not switch to the buffer."
 558   (when entries
 559     (let ((buf (if (and (eq major-mode
 560                             (guix-get-symbol "mode" buffer-type entry-type))
 561                         (equal guix-profile profile))
 562                    (current-buffer)
 563                  (get-buffer-create
 564                   (guix-buffer-name profile buffer-type
 565                                     entry-type search-type)))))
 566       (with-current-buffer buf
 567         (guix-show-entries entries buffer-type entry-type)
 568         (guix-set-vars profile entries buffer-type entry-type
 569                        search-type search-vals)
 570         (funcall (if history-replace
 571                      #'guix-history-replace
 572                    #'guix-history-add)
 573                  (guix-make-history-item)))
 574       (or no-display
 575           (guix-switch-to-buffer buf))))
 576   (guix-result-message profile entries entry-type
 577                        search-type search-vals))
 578
 579 (defun guix-show-entries (entries buffer-type entry-type)
 580   "Display ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer."
 581   (let ((inhibit-read-only t))
 582     (erase-buffer)
 583     (funcall (symbol-function (guix-get-symbol
 584                                "mode" buffer-type entry-type)))
 585     (funcall (guix-get-symbol "insert-entries" buffer-type)
 586              entries entry-type)
 587     (goto-char (point-min))))
 588
 589 (defun guix-history-call (profile entries buffer-type entry-type
 590                           search-type search-vals)
 591   "Function called for moving by history."
 592   (guix-show-entries entries buffer-type entry-type)
 593   (guix-set-vars profile entries buffer-type entry-type
 594                  search-type search-vals)
 595   (guix-result-message profile entries entry-type
 596                        search-type search-vals))
 597
 598 (defun guix-make-history-item ()
 599   "Make and return a history item for the current buffer."
 600   (list #'guix-history-call
 601         guix-profile guix-entries guix-buffer-type guix-entry-type
 602         guix-search-type guix-search-vals))
 603
 604 (defun guix-get-params-for-receiving (buffer-type entry-type)
 605   "Return parameters that should be received for BUFFER-TYPE, ENTRY-TYPE."
 606   (let* ((required-var (guix-get-symbol "required-params"
 607                                         buffer-type entry-type))
 608          (required (symbol-value required-var)))
 609     (unless (equal required 'all)
 610       (cl-union required
 611                 (funcall (guix-get-symbol "get-displayed-params"
 612                                           buffer-type)
 613                          entry-type)))))
 614
 615 (defun guix-revert-buffer (_ignore-auto noconfirm)
 616   "Update information in the current buffer.
 617 The function is suitable for `revert-buffer-function'.
 618 See `revert-buffer' for the meaning of NOCONFIRM."
 619   (when (or noconfirm
 620             (symbol-value
 621              (guix-get-symbol "revert-no-confirm"
 622                               guix-buffer-type guix-entry-type))
 623             (y-or-n-p "Update current information? "))
 624     (let* ((search-type guix-search-type)
 625            (search-vals guix-search-vals)
 626            (params (guix-get-params-for-receiving guix-buffer-type
 627                                                   guix-entry-type))
 628            (entries (guix-get-entries
 629                      guix-profile guix-entry-type
 630                      guix-search-type guix-search-vals params))
 631            ;; If a REPL was restarted, package/output IDs are not actual
 632            ;; anymore, because 'object-address'-es died with the REPL, so if a
 633            ;; search by ID didn't give results, search again by name.
 634            (entries (if (and (null entries)
 635                              (eq guix-search-type 'id)
 636                              (or (eq guix-entry-type 'package)
 637                                  (eq guix-entry-type 'output)))
 638                         (progn
 639                           (setq search-type 'name
 640                                 search-vals (guix-entries-to-specifications
 641                                              guix-entries))
 642                           (guix-get-entries
 643                            guix-profile guix-entry-type
 644                            search-type search-vals params))
 645                       entries)))
 646       (guix-set-buffer guix-profile entries guix-buffer-type guix-entry-type
 647                        search-type search-vals t t))))
 648
 649 (cl-defun guix-redisplay-buffer (&key buffer profile entries buffer-type
 650                                       entry-type search-type search-vals)
 651   "Redisplay a Guix BUFFER.
 652 Restore the point and window positions after redisplaying if possible.
 653
 654 This function will not update the information, use
 655 \"\\[revert-buffer]\" if you want the full update.
 656
 657 If BUFFER is nil, use the current buffer.  For the meaning of the
 658 rest arguments, see `guix-set-buffer'."
 659   (interactive)
 660   (or buffer (setq buffer (current-buffer)))
 661   (with-current-buffer buffer
 662     (or (derived-mode-p 'guix-info-mode 'guix-list-mode)
 663         (error "%S is not a Guix buffer" buffer))
 664     (let* ((point (point))
 665            (was-at-button (button-at point))
 666            ;; For simplicity, ignore an unlikely case when multiple
 667            ;; windows display the same BUFFER.
 668            (window (car (get-buffer-window-list buffer nil t)))
 669            (window-start (and window (window-start window))))
 670       (guix-set-buffer (or profile     guix-profile)
 671                        (or entries     guix-entries)
 672                        (or buffer-type guix-buffer-type)
 673                        (or entry-type  guix-entry-type)
 674                        (or search-type guix-search-type)
 675                        (or search-vals guix-search-vals)
 676                        t t)
 677       (goto-char point)
 678       (and was-at-button
 679            (not (button-at (point)))
 680            (forward-button 1))
 681       (when window
 682         (set-window-point window (point))
 683         (set-window-start window window-start)))))
 684
 685 \f
 686 ;;; Generations
 687
 688 (defcustom guix-generation-packages-buffer-name-function
 689   #'guix-generation-packages-buffer-name-default
 690   "Function used to define name of a buffer with generation packages.
 691 This function is called with 2 arguments: PROFILE (string) and
 692 GENERATION (number)."
 693   :type '(choice (function-item guix-generation-packages-buffer-name-default)
 694                  (function-item guix-generation-packages-buffer-name-long)
 695                  (function :tag "Other function"))
 696   :group 'guix)
 697
 698 (defcustom guix-generation-packages-update-buffer t
 699   "If non-nil, always update list of packages during comparing generations.
 700 If nil, generation packages are received only once.  So when you
 701 compare generation 1 and generation 2, the packages for both
 702 generations will be received.  Then if you compare generation 1
 703 and generation 3, only the packages for generation 3 will be
 704 received.  Thus if you use comparing of different generations a
 705 lot, you may set this variable to nil to improve the
 706 performance."
 707   :type 'boolean
 708   :group 'guix)
 709
 710 (defvar guix-output-name-width 30
 711   "Width of an output name \"column\".
 712 This variable is used in auxiliary buffers for comparing generations.")
 713
 714 (defun guix-generation-file (profile generation)
 715   "Return the file name of a PROFILE's GENERATION."
 716   (format "%s-%s-link" profile generation))
 717
 718 (defun guix-manifest-file (profile &optional generation)
 719   "Return the file name of a PROFILE's manifest.
 720 If GENERATION number is specified, return manifest file name for
 721 this generation."
 722   (expand-file-name "manifest"
 723                     (if generation
 724                         (guix-generation-file profile generation)
 725                       profile)))
 726
 727 (defun guix-generation-packages (profile generation)
 728   "Return a list of sorted packages installed in PROFILE's GENERATION.
 729 Each element of the list is a list of the package specification and its path."
 730   (let ((names+paths (guix-eval-read
 731                       (guix-make-guile-expression
 732                        'generation-package-specifications+paths
 733                        profile generation))))
 734     (sort names+paths
 735           (lambda (a b)
 736             (string< (car a) (car b))))))
 737
 738 (defun guix-generation-packages-buffer-name-default (profile generation)
 739   "Return name of a buffer for displaying GENERATION's package outputs.
 740 Use base name of PROFILE path."
 741   (let ((profile-name (file-name-base (directory-file-name profile))))
 742     (format "*Guix %s: generation %s*"
 743             profile-name generation)))
 744
 745 (defun guix-generation-packages-buffer-name-long (profile generation)
 746   "Return name of a buffer for displaying GENERATION's package outputs.
 747 Use the full PROFILE path."
 748   (format "*Guix generation %s (%s)*"
 749           generation profile))
 750
 751 (defun guix-generation-packages-buffer-name (profile generation)
 752   "Return name of a buffer for displaying GENERATION's package outputs."
 753   (let ((fun (if (functionp guix-generation-packages-buffer-name-function)
 754                  guix-generation-packages-buffer-name-function
 755                #'guix-generation-packages-buffer-name-default)))
 756     (funcall fun profile generation)))
 757
 758 (defun guix-generation-insert-package (name path)
 759   "Insert package output NAME and PATH at point."
 760   (insert name)
 761   (indent-to guix-output-name-width 2)
 762   (insert path "\n"))
 763
 764 (defun guix-generation-insert-packages (buffer profile generation)
 765   "Insert package outputs installed in PROFILE's GENERATION in BUFFER."
 766   (with-current-buffer buffer
 767     (setq buffer-read-only nil
 768           indent-tabs-mode nil)
 769     (erase-buffer)
 770     (mapc (lambda (name+path)
 771             (guix-generation-insert-package
 772              (car name+path) (cadr name+path)))
 773           (guix-generation-packages profile generation))))
 774
 775 (defun guix-generation-packages-buffer (profile generation)
 776   "Return buffer with package outputs installed in PROFILE's GENERATION.
 777 Create the buffer if needed."
 778   (let ((buf-name (guix-generation-packages-buffer-name
 779                    profile generation)))
 780     (or (and (null guix-generation-packages-update-buffer)
 781              (get-buffer buf-name))
 782         (let ((buf (get-buffer-create buf-name)))
 783           (guix-generation-insert-packages buf profile generation)
 784           buf))))
 785
 786 (defun guix-profile-generation-manifest-file (generation)
 787   "Return the file name of a GENERATION's manifest.
 788 GENERATION is a generation number of `guix-profile' profile."
 789   (guix-manifest-file guix-profile generation))
 790
 791 (defun guix-profile-generation-packages-buffer (generation)
 792   "Insert GENERATION's package outputs in a buffer and return it.
 793 GENERATION is a generation number of `guix-profile' profile."
 794   (guix-generation-packages-buffer guix-profile generation))
 795
 796 \f
 797 ;;; Actions on packages and generations
 798
 799 (defface guix-operation-option-key
 800   '((t :inherit font-lock-warning-face))
 801   "Face used for the keys of operation options."
 802   :group 'guix-faces)
 803
 804 (defcustom guix-operation-confirm t
 805   "If nil, do not prompt to confirm an operation."
 806   :type 'boolean
 807   :group 'guix)
 808
 809 (defcustom guix-use-substitutes t
 810   "If non-nil, use substitutes for the Guix packages."
 811   :type 'boolean
 812   :group 'guix)
 813
 814 (defvar guix-dry-run nil
 815   "If non-nil, do not perform the real actions, just simulate.")
 816
 817 (defvar guix-temp-buffer-name " *Guix temp*"
 818   "Name of a buffer used for displaying info before executing operation.")
 819
 820 (defvar guix-operation-option-true-string "yes"
 821   "String displayed in the mode-line when operation option is t.")
 822
 823 (defvar guix-operation-option-false-string "no "
 824   "String displayed in the mode-line when operation option is nil.")
 825
 826 (defvar guix-operation-option-separator "  |  "
 827   "String used in the mode-line to separate operation options.")
 828
 829 (defvar guix-operation-options
 830   '((?s "substitutes" guix-use-substitutes)
 831     (?d "dry-run"     guix-dry-run))
 832   "List of available operation options.
 833 Each element of the list has a form:
 834
 835   (KEY NAME VARIABLE)
 836
 837 KEY is a character that may be pressed during confirmation to
 838 toggle the option.
 839 NAME is a string displayed in the mode-line.
 840 VARIABLE is a name of an option variable.")
 841
 842 (defun guix-operation-option-by-key (key)
 843   "Return operation option by KEY (character)."
 844   (assq key guix-operation-options))
 845
 846 (defun guix-operation-option-key (option)
 847   "Return key (character) of the operation OPTION."
 848   (car option))
 849
 850 (defun guix-operation-option-name (option)
 851   "Return name of the operation OPTION."
 852   (nth 1 option))
 853
 854 (defun guix-operation-option-variable (option)
 855   "Return name of the variable of the operation OPTION."
 856   (nth 2 option))
 857
 858 (defun guix-operation-option-value (option)
 859   "Return boolean value of the operation OPTION."
 860   (symbol-value (guix-operation-option-variable option)))
 861
 862 (defun guix-operation-option-string-value (option)
 863   "Convert boolean value of the operation OPTION to string and return it."
 864   (if (guix-operation-option-value option)
 865       guix-operation-option-true-string
 866     guix-operation-option-false-string))
 867
 868 (defun guix-process-package-actions (profile actions
 869                                      &optional operation-buffer)
 870   "Process package ACTIONS on PROFILE.
 871 Each action is a list of the form:
 872
 873   (ACTION-TYPE PACKAGE-SPEC ...)
 874
 875 ACTION-TYPE is one of the following symbols: `install',
 876 `upgrade', `remove'/`delete'.
 877 PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)."
 878   (let (install upgrade remove)
 879     (mapc (lambda (action)
 880             (let ((action-type (car action))
 881                   (specs (cdr action)))
 882               (cl-case action-type
 883                 (install (setq install (append install specs)))
 884                 (upgrade (setq upgrade (append upgrade specs)))
 885                 ((remove delete) (setq remove (append remove specs))))))
 886           actions)
 887     (when (guix-continue-package-operation-p
 888            profile
 889            :install install :upgrade upgrade :remove remove)
 890       (guix-eval-in-repl
 891        (guix-make-guile-expression
 892         'process-package-actions profile
 893         :install install :upgrade upgrade :remove remove
 894         :use-substitutes? (or guix-use-substitutes 'f)
 895         :dry-run? (or guix-dry-run 'f))
 896        (and (not guix-dry-run) operation-buffer)))))
 897
 898 (cl-defun guix-continue-package-operation-p (profile
 899                                              &key install upgrade remove)
 900   "Return non-nil if a package operation should be continued.
 901 Ask a user if needed (see `guix-operation-confirm').
 902 INSTALL, UPGRADE, REMOVE are 'package action specifications'.
 903 See `guix-process-package-actions' for details."
 904   (or (null guix-operation-confirm)
 905       (let* ((entries (guix-get-entries
 906                        profile 'package 'id
 907                        (append (mapcar #'car install)
 908                                (mapcar #'car upgrade)
 909                                (mapcar #'car remove))
 910                        '(id name version location)))
 911              (install-strings (guix-get-package-strings install entries))
 912              (upgrade-strings (guix-get-package-strings upgrade entries))
 913              (remove-strings  (guix-get-package-strings remove entries)))
 914         (if (or install-strings upgrade-strings remove-strings)
 915             (let ((buf (get-buffer-create guix-temp-buffer-name)))
 916               (with-current-buffer buf
 917                 (setq-local cursor-type nil)
 918                 (setq buffer-read-only nil)
 919                 (erase-buffer)
 920                 (insert "Profile: " profile "\n\n")
 921                 (guix-insert-package-strings install-strings "install")
 922                 (guix-insert-package-strings upgrade-strings "upgrade")
 923                 (guix-insert-package-strings remove-strings "remove")
 924                 (let ((win (temp-buffer-window-show
 925                             buf
 926                             '((display-buffer-reuse-window
 927                                display-buffer-at-bottom)
 928                               (window-height . fit-window-to-buffer)))))
 929                   (prog1 (guix-operation-prompt)
 930                     (quit-window nil win)))))
 931           (message "Nothing to be done.  If the REPL was restarted, information is not up-to-date.")
 932           nil))))
 933
 934 (defun guix-get-package-strings (specs entries)
 935   "Return short package descriptions for performing package actions.
 936 See `guix-process-package-actions' for the meaning of SPECS.
 937 ENTRIES is a list of package entries to get info about packages."
 938   (delq nil
 939         (mapcar
 940          (lambda (spec)
 941            (let* ((id (car spec))
 942                   (outputs (cdr spec))
 943                   (entry (guix-get-entry-by-id id entries)))
 944              (when entry
 945                (let ((location (guix-assq-value entry 'location)))
 946                  (concat (guix-get-full-name entry)
 947                          (when outputs
 948                            (concat ":"
 949                                    (guix-concat-strings outputs ",")))
 950                          (when location
 951                            (concat "\t(" location ")")))))))
 952          specs)))
 953
 954 (defun guix-insert-package-strings (strings action)
 955   "Insert information STRINGS at point for performing package ACTION."
 956   (when strings
 957     (insert "Package(s) to " (propertize action 'face 'bold) ":\n")
 958     (mapc (lambda (str)
 959             (insert "  " str "\n"))
 960           strings)
 961     (insert "\n")))
 962
 963 (defun guix-operation-prompt (&optional prompt)
 964   "Prompt a user for continuing the current operation.
 965 Return non-nil, if the operation should be continued; nil otherwise.
 966 Ask a user with PROMPT for continuing an operation."
 967   (let* ((option-keys (mapcar #'guix-operation-option-key
 968                               guix-operation-options))
 969          (keys (append '(?y ?n) option-keys))
 970          (prompt (concat (propertize (or prompt "Continue operation?")
 971                                      'face 'minibuffer-prompt)
 972                          " ("
 973                          (mapconcat
 974                           (lambda (key)
 975                             (propertize (string key)
 976                                         'face 'guix-operation-option-key))
 977                           keys
 978                           ", ")
 979                          ") ")))
 980     (let ((mode-line mode-line-format))
 981       (prog1 (guix-operation-prompt-1 prompt keys)
 982         (setq mode-line-format mode-line)
 983         ;; Clear the minibuffer after prompting.
 984         (message "")))))
 985
 986 (defun guix-operation-prompt-1 (prompt keys)
 987   "This function is internal for `guix-operation-prompt'."
 988   (guix-operation-set-mode-line)
 989   (let ((key (read-char-choice prompt (cons ?\C-g keys) t)))
 990     (cl-case key
 991       (?y t)
 992       ((?n ?\C-g) nil)
 993       (t (let* ((option (guix-operation-option-by-key key))
 994                 (var (guix-operation-option-variable option)))
 995            (set var (not (symbol-value var)))
 996            (guix-operation-prompt-1 prompt keys))))))
 997
 998 (defun guix-operation-set-mode-line ()
 999   "Display operation options in the mode-line of the current buffer."
1000   (setq mode-line-format
1001         (concat (propertize " Options:   "
1002                             'face 'mode-line-buffer-id)
1003                 (mapconcat
1004                  (lambda (option)
1005                    (let ((key  (guix-operation-option-key option))
1006                          (name (guix-operation-option-name option))
1007                          (val  (guix-operation-option-string-value option)))
1008                      (concat name
1009                              " ("
1010                              (propertize (string key)
1011                                          'face 'guix-operation-option-key)
1012                              "): " val)))
1013                  guix-operation-options
1014                  guix-operation-option-separator)))
1015   (force-mode-line-update))
1016
1017 (defun guix-delete-generations (profile generations
1018                                 &optional operation-buffer)
1019   "Delete GENERATIONS from PROFILE.
1020 Each element from GENERATIONS is a generation number."
1021   (when (or (not guix-operation-confirm)
1022             (y-or-n-p
1023              (let ((count (length generations)))
1024                (if (> count 1)
1025                    (format "Delete %d generations from profile '%s'? "
1026                            count profile)
1027                  (format "Delete generation %d from profile '%s'? "
1028                          (car generations) profile)))))
1029     (guix-eval-in-repl
1030      (guix-make-guile-expression
1031       'delete-generations* profile generations)
1032      operation-buffer)))
1033
1034 (defun guix-switch-to-generation (profile generation
1035                                   &optional operation-buffer)
1036   "Switch PROFILE to GENERATION."
1037   (when (or (not guix-operation-confirm)
1038             (y-or-n-p (format "Switch profile '%s' to generation %d? "
1039                               profile generation)))
1040     (guix-eval-in-repl
1041      (guix-make-guile-expression
1042       'switch-to-generation* profile generation)
1043      operation-buffer)))
1044
1045 (defun guix-package-source-path (package-id)
1046   "Return a store file path to a source of a package PACKAGE-ID."
1047   (message "Calculating the source derivation ...")
1048   (guix-eval-read
1049    (guix-make-guile-expression
1050     'package-source-path package-id)))
1051
1052 (defvar guix-after-source-download-hook nil
1053   "Hook run after successful performing a 'source-download' operation.")
1054
1055 (defun guix-package-source-build-derivation (package-id &optional prompt)
1056   "Build source derivation of a package PACKAGE-ID.
1057 Ask a user with PROMPT for continuing an operation."
1058   (when (or (not guix-operation-confirm)
1059             (guix-operation-prompt (or prompt
1060                                        "Build the source derivation?")))
1061     (guix-eval-in-repl
1062      (guix-make-guile-expression
1063       'package-source-build-derivation
1064       package-id
1065       :use-substitutes? (or guix-use-substitutes 'f)
1066       :dry-run? (or guix-dry-run 'f))
1067      nil 'source-download)))
1068
1069 ;;;###autoload
1070 (defun guix-apply-manifest (profile file &optional operation-buffer)
1071   "Apply manifest from FILE to PROFILE.
1072 This function has the same meaning as 'guix package --manifest' command.
1073 See Info node `(guix) Invoking guix package' for details.
1074
1075 Interactively, use the current profile and prompt for manifest
1076 FILE.  With a prefix argument, also prompt for PROFILE."
1077   (interactive
1078    (let* ((default-profile (or guix-profile guix-current-profile))
1079           (profile (if current-prefix-arg
1080                        (guix-profile-prompt)
1081                      default-profile))
1082           (file (read-file-name "File with manifest: "))
1083           (buffer (and guix-profile (current-buffer))))
1084      (list profile file buffer)))
1085   (when (or (not guix-operation-confirm)
1086             (y-or-n-p (format "Apply manifest from '%s' to profile '%s'? "
1087                               file profile)))
1088     (guix-eval-in-repl
1089      (guix-make-guile-expression
1090       'guix-package
1091       (concat "--profile=" profile)
1092       (concat "--manifest=" file))
1093      operation-buffer)))
1094
1095 \f
1096 ;;; Executing guix commands
1097
1098 (defcustom guix-run-in-shell-function #'guix-run-in-shell
1099   "Function used to run guix command.
1100 The function is called with a single argument - a command line string."
1101   :type '(choice (function-item guix-run-in-shell)
1102                  (function-item guix-run-in-eshell)
1103                  (function :tag "Other function"))
1104   :group 'guix)
1105
1106 (defcustom guix-shell-buffer-name "*shell*"
1107   "Default name of a shell buffer used for running guix commands."
1108   :type 'string
1109   :group 'guix)
1110
1111 (declare-function comint-send-input "comint" t)
1112
1113 (defun guix-run-in-shell (string)
1114   "Run command line STRING in `guix-shell-buffer-name' buffer."
1115   (shell guix-shell-buffer-name)
1116   (goto-char (point-max))
1117   (insert string)
1118   (comint-send-input))
1119
1120 (declare-function eshell-send-input "esh-mode" t)
1121
1122 (defun guix-run-in-eshell (string)
1123   "Run command line STRING in eshell buffer."
1124   (eshell)
1125   (goto-char (point-max))
1126   (insert string)
1127   (eshell-send-input))
1128
1129 (defun guix-run-command-in-shell (args)
1130   "Execute 'guix ARGS ...' command in a shell buffer."
1131   (funcall guix-run-in-shell-function
1132            (guix-command-string args)))
1133
1134 (defun guix-run-command-in-repl (args)
1135   "Execute 'guix ARGS ...' command in Guix REPL."
1136   (guix-eval-in-repl
1137    (apply #'guix-make-guile-expression
1138           'guix-command args)))
1139
1140 (defun guix-command-output (args)
1141   "Return string with 'guix ARGS ...' output."
1142   (cl-multiple-value-bind (output error)
1143       (guix-eval (apply #'guix-make-guile-expression
1144                         'guix-command-output args))
1145     ;; Remove trailing new space from the error string.
1146     (message (replace-regexp-in-string "\n\\'" "" (read error)))
1147     (read output)))
1148
1149 (defun guix-help-string (&optional commands)
1150   "Return string with 'guix COMMANDS ... --help' output."
1151   (guix-eval-read
1152    (apply #'guix-make-guile-expression
1153           'help-string commands)))
1154
1155 \f
1156 ;;; Pull
1157
1158 (defcustom guix-update-after-pull t
1159   "If non-nil, update Guix buffers after performing \\[guix-pull]."
1160   :type 'boolean
1161   :group 'guix)
1162
1163 (defvar guix-after-pull-hook
1164   '(guix-restart-repl-after-pull guix-update-buffers-maybe-after-pull)
1165   "Hook run after successful performing `guix-pull' operation.")
1166
1167 (defun guix-restart-repl-after-pull ()
1168   "Restart Guix REPL after `guix-pull' operation."
1169   (guix-repl-exit)
1170   (guix-start-process-maybe
1171    "Restarting Guix REPL after pull operation ..."))
1172
1173 (defun guix-update-buffers-maybe-after-pull ()
1174   "Update buffers depending on `guix-update-after-pull'."
1175   (when guix-update-after-pull
1176     (mapc #'guix-update-buffer
1177           ;; No need to update "generation" buffers.
1178           (guix-buffers '(guix-package-list-mode
1179                           guix-package-info-mode
1180                           guix-output-list-mode
1181                           guix-output-info-mode)))
1182     (message "Guix buffers have been updated.")))
1183
1184 ;;;###autoload
1185 (defun guix-pull (&optional verbose)
1186   "Run Guix pull operation.
1187 If VERBOSE is non-nil (with prefix argument), produce verbose output."
1188   (interactive)
1189   (let ((args (and verbose '("--verbose"))))
1190     (guix-eval-in-repl
1191      (apply #'guix-make-guile-expression 'guix-pull args)
1192      nil 'pull)))
1193
1194 (provide 'guix-base)
1195
1196 ;;; guix-base.el ends here