Commit | Line | Data |
---|---|---|
dfeb0239 | 1 | ;;; guix-base.el --- Common definitions -*- lexical-binding: t -*- |
457f60fa AK |
2 | |
3 | ;; Copyright © 2014 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-backend) | |
32 | (require 'guix-utils) | |
33 | ||
34 | \f | |
35 | ;;; Profiles | |
36 | ||
37 | (defvar guix-user-profile | |
38 | (expand-file-name "~/.guix-profile") | |
39 | "User profile.") | |
40 | ||
41 | (defvar guix-default-profile | |
42 | (concat (or (getenv "NIX_STATE_DIR") "/var/guix") | |
43 | "/profiles/per-user/" | |
44 | (getenv "USER") | |
45 | "/guix-profile") | |
46 | "Default Guix profile.") | |
47 | ||
48 | (defvar guix-current-profile guix-default-profile | |
49 | "Current profile.") | |
50 | ||
23459fa5 AK |
51 | (defun guix-profile-prompt (&optional default) |
52 | "Prompt for profile and return it. | |
53 | Use DEFAULT as a start directory. If it is nil, use | |
54 | `guix-current-profile'." | |
55 | (let* ((path (read-file-name "Profile: " | |
56 | (file-name-directory | |
57 | (or default guix-current-profile)))) | |
58 | (path (directory-file-name (expand-file-name path)))) | |
59 | (if (string= path guix-user-profile) | |
60 | guix-default-profile | |
61 | path))) | |
62 | ||
457f60fa AK |
63 | (defun guix-set-current-profile (path) |
64 | "Set `guix-current-profile' to PATH. | |
65 | Interactively, prompt for PATH. With prefix, use | |
66 | `guix-default-profile'." | |
67 | (interactive | |
68 | (list (if current-prefix-arg | |
69 | guix-default-profile | |
23459fa5 AK |
70 | (guix-profile-prompt)))) |
71 | (setq guix-current-profile path) | |
72 | (message "Current profile has been set to '%s'." | |
73 | guix-current-profile)) | |
457f60fa AK |
74 | |
75 | \f | |
76 | ;;; Parameters of the entries | |
77 | ||
78 | (defvar guix-param-titles | |
79 | '((package | |
80 | (id . "ID") | |
81 | (name . "Name") | |
82 | (version . "Version") | |
83 | (license . "License") | |
84 | (synopsis . "Synopsis") | |
85 | (description . "Description") | |
86 | (home-url . "Home page") | |
87 | (outputs . "Outputs") | |
88 | (inputs . "Inputs") | |
89 | (native-inputs . "Native inputs") | |
90 | (propagated-inputs . "Propagated inputs") | |
91 | (location . "Location") | |
92 | (installed . "Installed")) | |
93 | (installed | |
94 | (path . "Installed path") | |
95 | (dependencies . "Dependencies") | |
96 | (output . "Output")) | |
a54a237b AK |
97 | (output |
98 | (id . "ID") | |
99 | (name . "Name") | |
100 | (version . "Version") | |
101 | (license . "License") | |
102 | (synopsis . "Synopsis") | |
103 | (description . "Description") | |
104 | (home-url . "Home page") | |
105 | (output . "Output") | |
106 | (inputs . "Inputs") | |
107 | (native-inputs . "Native inputs") | |
108 | (propagated-inputs . "Propagated inputs") | |
109 | (location . "Location") | |
110 | (installed . "Installed") | |
111 | (path . "Installed path") | |
112 | (dependencies . "Dependencies")) | |
457f60fa AK |
113 | (generation |
114 | (id . "ID") | |
115 | (number . "Number") | |
116 | (prev-number . "Previous number") | |
c2379b3c | 117 | (current . "Current") |
457f60fa AK |
118 | (path . "Path") |
119 | (time . "Time"))) | |
120 | "List for defining titles of entry parameters. | |
121 | Titles are used for displaying information about entries. | |
122 | Each element of the list has a form: | |
123 | ||
124 | (ENTRY-TYPE . ((PARAM . TITLE) ...))") | |
125 | ||
126 | (defun guix-get-param-title (entry-type param) | |
127 | "Return title of an ENTRY-TYPE entry parameter PARAM." | |
128 | (or (guix-get-key-val guix-param-titles | |
129 | entry-type param) | |
130 | (prog1 (symbol-name param) | |
131 | (message "Couldn't find title for '%S %S'." | |
132 | entry-type param)))) | |
133 | ||
134 | (defun guix-get-name-spec (name version &optional output) | |
135 | "Return Guix package specification by its NAME, VERSION and OUTPUT." | |
136 | (concat name "-" version | |
137 | (when output (concat ":" output)))) | |
138 | ||
139 | (defun guix-get-full-name (entry &optional output) | |
140 | "Return name specification of the package ENTRY and OUTPUT." | |
141 | (guix-get-name-spec (guix-get-key-val entry 'name) | |
142 | (guix-get-key-val entry 'version) | |
143 | output)) | |
144 | ||
145 | (defun guix-get-installed-outputs (entry) | |
146 | "Return list of installed outputs for the package ENTRY." | |
147 | (mapcar (lambda (installed-entry) | |
148 | (guix-get-key-val installed-entry 'output)) | |
149 | (guix-get-key-val entry 'installed))) | |
150 | ||
151 | (defun guix-get-entry-by-id (id entries) | |
152 | "Return entry from ENTRIES by entry ID." | |
153 | (cl-find-if (lambda (entry) | |
154 | (equal id (guix-get-key-val entry 'id))) | |
155 | entries)) | |
156 | ||
a54a237b AK |
157 | (defun guix-get-package-id-and-output-by-output-id (oid) |
158 | "Return list (PACKAGE-ID OUTPUT) by output id OID." | |
159 | (cl-multiple-value-bind (pid-str output) | |
160 | (split-string oid ":") | |
161 | (let ((pid (string-to-number pid-str))) | |
162 | (list (if (= 0 pid) pid-str pid) | |
163 | output)))) | |
164 | ||
457f60fa AK |
165 | \f |
166 | ;;; Location of the packages | |
167 | ||
168 | (defvar guix-directory nil | |
169 | "Default Guix directory. | |
170 | If it is not set by a user, it is set after starting Guile REPL. | |
171 | This directory is used to define location of the packages.") | |
172 | ||
173 | (defun guix-set-directory () | |
174 | "Set `guix-directory' if needed." | |
175 | (or guix-directory | |
176 | (setq guix-directory | |
177 | (guix-eval-read "%guix-dir")))) | |
178 | ||
179 | (add-hook 'guix-after-start-repl-hook 'guix-set-directory) | |
180 | ||
181 | (defun guix-find-location (location) | |
182 | "Go to LOCATION of a package. | |
183 | LOCATION is a string of the form: | |
184 | ||
185 | \"PATH:LINE:COLUMN\" | |
186 | ||
187 | If PATH is relative, it is considered to be relative to | |
188 | `guix-directory'." | |
189 | (cl-multiple-value-bind (path line col) | |
190 | (split-string location ":") | |
191 | (let ((file (expand-file-name path guix-directory)) | |
192 | (line (string-to-number line)) | |
193 | (col (string-to-number col))) | |
194 | (find-file file) | |
195 | (goto-char (point-min)) | |
196 | (forward-line (- line 1)) | |
197 | (move-to-column col) | |
198 | (recenter 1)))) | |
199 | ||
200 | \f | |
49d758d2 AK |
201 | ;;; Buffers and auto updating. |
202 | ||
203 | (defcustom guix-update-after-operation 'current | |
204 | "Define what information to update after executing an operation. | |
205 | ||
206 | After successful executing an operation in the Guix REPL (for | |
207 | example after installing a package), information in Guix buffers | |
208 | will or will not be automatically updated depending on a value of | |
209 | this variable. | |
210 | ||
211 | If nil, update nothing (do not revert any buffer). | |
212 | If `current', update the buffer from which an operation was performed. | |
213 | If `all', update all Guix buffers (not recommended)." | |
214 | :type '(choice (const :tag "Do nothing" nil) | |
215 | (const :tag "Update operation buffer" current) | |
216 | (const :tag "Update all Guix buffers" all)) | |
217 | :group 'guix) | |
218 | ||
23459fa5 AK |
219 | (defcustom guix-buffer-name-function #'guix-buffer-name-default |
220 | "Function used to define name of a buffer for displaying information. | |
221 | The function is called with 4 arguments: PROFILE, BUFFER-TYPE, | |
222 | ENTRY-TYPE, SEARCH-TYPE. See `guix-get-entries' for the meaning | |
223 | of the arguments." | |
224 | :type '(choice (function-item guix-buffer-name-default) | |
225 | (function-item guix-buffer-name-simple) | |
226 | (function :tag "Other function")) | |
227 | :group 'guix) | |
228 | ||
229 | (defun guix-buffer-name-simple (_profile buffer-type entry-type | |
230 | &optional _search-type) | |
231 | "Return name of a buffer used for displaying information. | |
232 | The name is defined by `guix-ENTRY-TYPE-BUFFER-TYPE-buffer-name' | |
233 | variable." | |
234 | (symbol-value | |
235 | (guix-get-symbol "buffer-name" buffer-type entry-type))) | |
236 | ||
237 | (defun guix-buffer-name-default (profile buffer-type entry-type | |
238 | &optional _search-type) | |
239 | "Return name of a buffer used for displaying information. | |
240 | The name is almost the same as the one defined by | |
241 | `guix-buffer-name-simple' except the PROFILE name is added to it." | |
242 | (let ((simple-name (guix-buffer-name-simple | |
243 | profile buffer-type entry-type)) | |
244 | (profile-name (file-name-base (directory-file-name profile))) | |
245 | (re (rx string-start | |
246 | (group (? "*")) | |
247 | (group (*? any)) | |
248 | (group (? "*")) | |
249 | string-end))) | |
250 | (or (string-match re simple-name) | |
251 | (error "Unexpected error in defining guix buffer name")) | |
252 | (let ((first* (match-string 1 simple-name)) | |
253 | (name-body (match-string 2 simple-name)) | |
254 | (last* (match-string 3 simple-name))) | |
255 | ;; Handle the case when buffer name is wrapped by '*'. | |
256 | (if (and (string= "*" first*) | |
257 | (string= "*" last*)) | |
258 | (concat "*" name-body ": " profile-name "*") | |
259 | (concat simple-name ": " profile-name))))) | |
260 | ||
261 | (defun guix-buffer-name (profile buffer-type entry-type search-type) | |
262 | "Return name of a buffer used for displaying information. | |
263 | See `guix-buffer-name-function' for details." | |
264 | (let ((fun (if (functionp guix-buffer-name-function) | |
265 | guix-buffer-name-function | |
266 | #'guix-buffer-name-default))) | |
267 | (funcall fun profile buffer-type entry-type search-type))) | |
268 | ||
49d758d2 AK |
269 | (defun guix-switch-to-buffer (buffer) |
270 | "Switch to a 'list' or 'info' BUFFER." | |
271 | (pop-to-buffer buffer | |
272 | '((display-buffer-reuse-window | |
273 | display-buffer-same-window)))) | |
274 | ||
275 | (defun guix-list-or-info-buffer-p (&optional buffer) | |
276 | "Return non-nil if BUFFER is a Guix 'list' or 'info' buffer. | |
277 | If BUFFER is nil, check current buffer." | |
278 | (with-current-buffer (or buffer (current-buffer)) | |
279 | (derived-mode-p 'guix-list-mode 'guix-info-mode))) | |
280 | ||
281 | (defun guix-buffers () | |
282 | "Return list of all Guix 'list' and 'info' buffers." | |
283 | (cl-remove-if-not #'guix-list-or-info-buffer-p | |
284 | (buffer-list))) | |
285 | ||
286 | (defun guix-update-buffers-maybe () | |
287 | "Update buffers after Guix operation if needed. | |
288 | See `guix-update-after-operation' for details." | |
289 | (let ((to-update (and guix-operation-buffer | |
290 | (cl-case guix-update-after-operation | |
291 | (current (list guix-operation-buffer)) | |
292 | (all (guix-buffers)))))) | |
293 | (setq guix-operation-buffer nil) | |
294 | (mapc (lambda (buf) | |
295 | (and (buffer-live-p buf) | |
296 | (guix-list-or-info-buffer-p buf) | |
297 | (with-current-buffer buf | |
298 | (guix-revert-buffer nil t)))) | |
299 | to-update))) | |
300 | ||
301 | (add-hook 'guix-after-repl-operation-hook 'guix-update-buffers-maybe) | |
302 | ||
303 | \f | |
457f60fa AK |
304 | ;;; Common definitions for buffer types |
305 | ||
23459fa5 AK |
306 | (defvar-local guix-profile nil |
307 | "Profile used for the current buffer.") | |
308 | (put 'guix-profile 'permanent-local t) | |
309 | ||
457f60fa AK |
310 | (defvar-local guix-entries nil |
311 | "List of the currently displayed entries. | |
312 | Each element of the list is alist with entry info of the | |
313 | following form: | |
314 | ||
315 | ((PARAM . VAL) ...) | |
316 | ||
317 | PARAM is a name of the entry parameter. | |
318 | VAL is a value of this parameter.") | |
319 | (put 'guix-entries 'permanent-local t) | |
320 | ||
dfeb0239 AK |
321 | (defvar-local guix-buffer-type nil |
322 | "Type of the current buffer.") | |
323 | (put 'guix-buffer-type 'permanent-local t) | |
324 | ||
325 | (defvar-local guix-entry-type nil | |
326 | "Type of the current entry.") | |
327 | (put 'guix-entry-type 'permanent-local t) | |
328 | ||
457f60fa AK |
329 | (defvar-local guix-search-type nil |
330 | "Type of the current search.") | |
331 | (put 'guix-search-type 'permanent-local t) | |
332 | ||
333 | (defvar-local guix-search-vals nil | |
334 | "Values of the current search.") | |
335 | (put 'guix-search-vals 'permanent-local t) | |
336 | ||
23459fa5 | 337 | (defsubst guix-set-vars (profile entries buffer-type entry-type |
dfeb0239 | 338 | search-type search-vals) |
23459fa5 AK |
339 | "Set local variables for the current Guix buffer." |
340 | (setq default-directory profile | |
341 | guix-profile profile | |
342 | guix-entries entries | |
343 | guix-buffer-type buffer-type | |
344 | guix-entry-type entry-type | |
345 | guix-search-type search-type | |
346 | guix-search-vals search-vals)) | |
457f60fa | 347 | |
dfeb0239 AK |
348 | (defun guix-get-symbol (postfix buffer-type &optional entry-type) |
349 | (intern (concat "guix-" | |
350 | (when entry-type | |
351 | (concat (symbol-name entry-type) "-")) | |
352 | (symbol-name buffer-type) "-" postfix))) | |
457f60fa | 353 | |
dfeb0239 AK |
354 | (defmacro guix-define-buffer-type (buf-type entry-type &rest args) |
355 | "Define common for BUF-TYPE buffers for displaying ENTRY-TYPE entries. | |
457f60fa AK |
356 | |
357 | In the text below TYPE means ENTRY-TYPE-BUF-TYPE. | |
358 | ||
dfeb0239 AK |
359 | This macro defines `guix-TYPE-mode', a custom group and several |
360 | user variables. | |
457f60fa AK |
361 | |
362 | The following stuff should be defined outside this macro: | |
363 | ||
364 | - `guix-BUF-TYPE-mode' - parent mode for the defined mode. | |
365 | ||
457f60fa AK |
366 | - `guix-TYPE-mode-initialize' (optional) - function for |
367 | additional mode settings; it is called without arguments. | |
368 | ||
369 | Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The | |
370 | following keywords are available: | |
371 | ||
a54a237b AK |
372 | - `:buffer-name' - default value for the defined |
373 | `guix-TYPE-buffer-name' variable. | |
374 | ||
457f60fa AK |
375 | - `:required' - default value for the defined |
376 | `guix-TYPE-required-params' variable. | |
377 | ||
378 | - `:history-size' - default value for the defined | |
379 | `guix-TYPE-history-size' variable. | |
380 | ||
381 | - `:revert' - default value for the defined | |
382 | `guix-TYPE-revert-no-confirm' variable." | |
383 | (let* ((entry-type-str (symbol-name entry-type)) | |
384 | (buf-type-str (symbol-name buf-type)) | |
385 | (Entry-type-str (capitalize entry-type-str)) | |
386 | (Buf-type-str (capitalize buf-type-str)) | |
387 | (entry-str (concat entry-type-str " entries")) | |
388 | (buf-str (concat buf-type-str " buffer")) | |
389 | (prefix (concat "guix-" entry-type-str "-" buf-type-str)) | |
390 | (group (intern prefix)) | |
391 | (mode-map-str (concat prefix "-mode-map")) | |
392 | (mode-map (intern mode-map-str)) | |
393 | (parent-mode (intern (concat "guix-" buf-type-str "-mode"))) | |
394 | (mode (intern (concat prefix "-mode"))) | |
395 | (mode-init-fun (intern (concat prefix "-mode-initialize"))) | |
396 | (buf-name-var (intern (concat prefix "-buffer-name"))) | |
397 | (revert-var (intern (concat prefix "-revert-no-confirm"))) | |
457f60fa | 398 | (history-var (intern (concat prefix "-history-size"))) |
457f60fa | 399 | (params-var (intern (concat prefix "-required-params"))) |
a54a237b | 400 | (buf-name-val (format "*Guix %s %s*" Entry-type-str Buf-type-str)) |
457f60fa AK |
401 | (revert-val nil) |
402 | (history-val 20) | |
403 | (params-val '(id))) | |
404 | ||
405 | ;; Process the keyword args. | |
406 | (while (keywordp (car args)) | |
407 | (pcase (pop args) | |
408 | (`:required (setq params-val (pop args))) | |
409 | (`:history-size (setq history-val (pop args))) | |
410 | (`:revert (setq revert-val (pop args))) | |
a54a237b | 411 | (`:buffer-name (setq buf-name-val (pop args))) |
457f60fa AK |
412 | (_ (pop args)))) |
413 | ||
414 | `(progn | |
415 | (defgroup ,group nil | |
416 | ,(concat Buf-type-str " buffer with " entry-str ".") | |
417 | :prefix ,(concat prefix "-") | |
418 | :group ',(intern (concat "guix-" buf-type-str))) | |
419 | ||
a54a237b | 420 | (defcustom ,buf-name-var ,buf-name-val |
457f60fa AK |
421 | ,(concat "Default name of the " buf-str " for displaying " entry-str ".") |
422 | :type 'string | |
423 | :group ',group) | |
424 | ||
425 | (defcustom ,history-var ,history-val | |
426 | ,(concat "Maximum number of items saved in the history of the " buf-str ".\n" | |
427 | "If 0, the history is disabled.") | |
428 | :type 'integer | |
429 | :group ',group) | |
430 | ||
431 | (defcustom ,revert-var ,revert-val | |
432 | ,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".") | |
433 | :type 'boolean | |
434 | :group ',group) | |
435 | ||
436 | (defvar ,params-var ',params-val | |
437 | ,(concat "List of required " entry-type-str " parameters.\n\n" | |
438 | "Displayed parameters and parameters from this list are received\n" | |
439 | "for each " entry-type-str ".\n\n" | |
440 | "May be a special value `all', in which case all supported\n" | |
441 | "parameters are received (this may be very slow for a big number\n" | |
442 | "of entries).\n\n" | |
443 | "Do not remove `id' from this list as it is required for\n" | |
444 | "identifying an entry.")) | |
445 | ||
446 | (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str) | |
447 | ,(concat "Major mode for displaying information about " entry-str ".\n\n" | |
448 | "\\{" mode-map-str "}") | |
dfeb0239 | 449 | (setq-local revert-buffer-function 'guix-revert-buffer) |
457f60fa AK |
450 | (setq-local guix-history-size ,history-var) |
451 | (and (fboundp ',mode-init-fun) (,mode-init-fun))) | |
452 | ||
453 | (let ((map ,mode-map)) | |
454 | (define-key map (kbd "l") 'guix-history-back) | |
455 | (define-key map (kbd "r") 'guix-history-forward) | |
456 | (define-key map (kbd "g") 'revert-buffer) | |
dfeb0239 AK |
457 | (define-key map (kbd "R") 'guix-redisplay-buffer) |
458 | (define-key map (kbd "C-c C-z") 'guix-switch-to-repl))))) | |
459 | ||
460 | (put 'guix-define-buffer-type 'lisp-indent-function 'defun) | |
461 | ||
462 | \f | |
3472bb20 AK |
463 | ;;; Getting and displaying info about packages and generations |
464 | ||
465 | (defcustom guix-package-list-type 'output | |
466 | "Define how to display packages in a list buffer. | |
467 | May be a symbol `package' or `output' (if `output', display each | |
468 | output on a separate line; if `package', display each package on | |
469 | a separate line)." | |
470 | :type '(choice (const :tag "List of packages" package) | |
471 | (const :tag "List of outputs" output)) | |
472 | :group 'guix) | |
473 | ||
474 | (defcustom guix-package-info-type 'package | |
475 | "Define how to display packages in an info buffer. | |
476 | May be a symbol `package' or `output' (if `output', display each | |
477 | output separately; if `package', display outputs inside a package | |
478 | information)." | |
479 | :type '(choice (const :tag "Display packages" package) | |
480 | (const :tag "Display outputs" output)) | |
481 | :group 'guix) | |
dfeb0239 | 482 | |
23459fa5 | 483 | (defun guix-get-entries (profile entry-type search-type search-vals |
dfeb0239 AK |
484 | &optional params) |
485 | "Search for entries of ENTRY-TYPE. | |
486 | ||
487 | Call an appropriate scheme function and return a list of the | |
488 | form of `guix-entries'. | |
489 | ||
81b339fe AK |
490 | ENTRY-TYPE should be one of the following symbols: `package', |
491 | `output' or `generation'. | |
dfeb0239 AK |
492 | |
493 | SEARCH-TYPE may be one of the following symbols: | |
494 | ||
495 | - If ENTRY-TYPE is `package' or `output': `id', `name', `regexp', | |
496 | `all-available', `newest-available', `installed', `obsolete', | |
497 | `generation'. | |
498 | ||
23459fa5 | 499 | - If ENTRY-TYPE is `generation': `id', `last', `all', `time'. |
dfeb0239 AK |
500 | |
501 | PARAMS is a list of parameters for receiving. If nil, get | |
502 | information with all available parameters." | |
503 | (guix-eval-read (guix-make-guile-expression | |
81b339fe | 504 | 'entries |
23459fa5 | 505 | profile params entry-type search-type search-vals))) |
dfeb0239 | 506 | |
23459fa5 AK |
507 | (defun guix-get-show-entries (profile buffer-type entry-type search-type |
508 | &rest search-vals) | |
dfeb0239 AK |
509 | "Search for ENTRY-TYPE entries and show results in BUFFER-TYPE buffer. |
510 | See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS." | |
23459fa5 | 511 | (let ((entries (guix-get-entries profile entry-type search-type search-vals |
dfeb0239 AK |
512 | (guix-get-params-for-receiving |
513 | buffer-type entry-type)))) | |
23459fa5 | 514 | (guix-set-buffer profile entries buffer-type entry-type |
dfeb0239 AK |
515 | search-type search-vals))) |
516 | ||
23459fa5 | 517 | (defun guix-set-buffer (profile entries buffer-type entry-type search-type |
49d758d2 | 518 | search-vals &optional history-replace no-display) |
dfeb0239 AK |
519 | "Set up BUFFER-TYPE buffer for displaying ENTRY-TYPE ENTRIES. |
520 | ||
49d758d2 | 521 | Insert ENTRIES in buffer, set variables and make history item. |
dfeb0239 AK |
522 | ENTRIES should have a form of `guix-entries'. |
523 | ||
524 | See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS. | |
525 | ||
526 | If HISTORY-REPLACE is non-nil, replace current history item, | |
49d758d2 AK |
527 | otherwise add the new one. |
528 | ||
529 | If NO-DISPLAY is non-nil, do not switch to the buffer." | |
dfeb0239 | 530 | (when entries |
23459fa5 AK |
531 | (let ((buf (if (and (eq major-mode |
532 | (guix-get-symbol "mode" buffer-type entry-type)) | |
533 | (equal guix-profile profile)) | |
dfeb0239 AK |
534 | (current-buffer) |
535 | (get-buffer-create | |
23459fa5 AK |
536 | (guix-buffer-name profile buffer-type |
537 | entry-type search-type))))) | |
dfeb0239 AK |
538 | (with-current-buffer buf |
539 | (guix-show-entries entries buffer-type entry-type) | |
23459fa5 | 540 | (guix-set-vars profile entries buffer-type entry-type |
dfeb0239 AK |
541 | search-type search-vals) |
542 | (funcall (if history-replace | |
543 | #'guix-history-replace | |
544 | #'guix-history-add) | |
545 | (guix-make-history-item))) | |
49d758d2 AK |
546 | (or no-display |
547 | (guix-switch-to-buffer buf)))) | |
dfeb0239 AK |
548 | (guix-result-message entries entry-type search-type search-vals)) |
549 | ||
550 | (defun guix-show-entries (entries buffer-type entry-type) | |
551 | "Display ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." | |
552 | (let ((inhibit-read-only t)) | |
553 | (erase-buffer) | |
554 | (funcall (symbol-function (guix-get-symbol | |
555 | "mode" buffer-type entry-type))) | |
556 | (funcall (guix-get-symbol "insert-entries" buffer-type) | |
557 | entries entry-type) | |
558 | (goto-char (point-min)))) | |
559 | ||
23459fa5 | 560 | (defun guix-history-call (profile entries buffer-type entry-type |
dfeb0239 AK |
561 | search-type search-vals) |
562 | "Function called for moving by history." | |
563 | (guix-show-entries entries buffer-type entry-type) | |
23459fa5 | 564 | (guix-set-vars profile entries buffer-type entry-type |
dfeb0239 AK |
565 | search-type search-vals) |
566 | (guix-result-message entries entry-type search-type search-vals)) | |
567 | ||
568 | (defun guix-make-history-item () | |
569 | "Make and return a history item for the current buffer." | |
570 | (list #'guix-history-call | |
23459fa5 | 571 | guix-profile guix-entries guix-buffer-type guix-entry-type |
dfeb0239 AK |
572 | guix-search-type guix-search-vals)) |
573 | ||
574 | (defun guix-get-params-for-receiving (buffer-type entry-type) | |
575 | "Return parameters that should be received for BUFFER-TYPE, ENTRY-TYPE." | |
576 | (let* ((required-var (guix-get-symbol "required-params" | |
577 | buffer-type entry-type)) | |
578 | (required (symbol-value required-var))) | |
579 | (unless (equal required 'all) | |
580 | (cl-union required | |
581 | (funcall (guix-get-symbol "get-displayed-params" | |
582 | buffer-type) | |
583 | entry-type))))) | |
584 | ||
585 | (defun guix-revert-buffer (_ignore-auto noconfirm) | |
586 | "Update information in the current buffer. | |
457f60fa AK |
587 | The function is suitable for `revert-buffer-function'. |
588 | See `revert-buffer' for the meaning of NOCONFIRM." | |
dfeb0239 AK |
589 | (when (or noconfirm |
590 | (symbol-value | |
591 | (guix-get-symbol "revert-no-confirm" | |
592 | guix-buffer-type guix-entry-type)) | |
593 | (y-or-n-p "Update current information? ")) | |
594 | (let ((entries (guix-get-entries | |
23459fa5 AK |
595 | guix-profile guix-entry-type |
596 | guix-search-type guix-search-vals | |
dfeb0239 AK |
597 | (guix-get-params-for-receiving guix-buffer-type |
598 | guix-entry-type)))) | |
23459fa5 | 599 | (guix-set-buffer guix-profile entries guix-buffer-type guix-entry-type |
49d758d2 | 600 | guix-search-type guix-search-vals t t)))) |
dfeb0239 AK |
601 | |
602 | (defun guix-redisplay-buffer () | |
603 | "Redisplay current information. | |
457f60fa AK |
604 | This function will not update the information, use |
605 | \"\\[revert-buffer]\" if you want the full update." | |
dfeb0239 AK |
606 | (interactive) |
607 | (guix-show-entries guix-entries guix-buffer-type guix-entry-type) | |
608 | (guix-result-message guix-entries guix-entry-type | |
609 | guix-search-type guix-search-vals)) | |
457f60fa AK |
610 | |
611 | \f | |
612 | ;;; Messages | |
613 | ||
614 | (defvar guix-messages | |
615 | '((package | |
616 | (id | |
617 | (0 "Packages not found.") | |
618 | (1 "") | |
619 | (many "%d packages." count)) | |
620 | (name | |
621 | (0 "The package '%s' not found." val) | |
622 | (1 "A single package with name '%s'." val) | |
623 | (many "%d packages with '%s' name." count val)) | |
624 | (regexp | |
625 | (0 "No packages matching '%s'." val) | |
626 | (1 "A single package matching '%s'." val) | |
627 | (many "%d packages matching '%s'." count val)) | |
628 | (all-available | |
629 | (0 "No packages are available for some reason.") | |
630 | (1 "A single available package (that's strange).") | |
631 | (many "%d available packages." count)) | |
632 | (newest-available | |
633 | (0 "No packages are available for some reason.") | |
634 | (1 "A single newest available package (that's strange).") | |
635 | (many "%d newest available packages." count)) | |
636 | (installed | |
637 | (0 "No installed packages.") | |
a54a237b AK |
638 | (1 "A single package installed.") |
639 | (many "%d packages installed." count)) | |
457f60fa AK |
640 | (obsolete |
641 | (0 "No obsolete packages.") | |
642 | (1 "A single obsolete package.") | |
643 | (many "%d obsolete packages." count)) | |
644 | (generation | |
645 | (0 "No packages installed in generation %d." val) | |
646 | (1 "A single package installed in generation %d." val) | |
647 | (many "%d packages installed in generation %d." count val))) | |
a54a237b AK |
648 | (output |
649 | (id | |
650 | (0 "Package outputs not found.") | |
651 | (1 "") | |
652 | (many "%d package outputs." count)) | |
653 | (name | |
654 | (0 "The package output '%s' not found." val) | |
655 | (1 "A single package output with name '%s'." val) | |
656 | (many "%d package outputs with '%s' name." count val)) | |
657 | (regexp | |
658 | (0 "No package outputs matching '%s'." val) | |
659 | (1 "A single package output matching '%s'." val) | |
660 | (many "%d package outputs matching '%s'." count val)) | |
661 | (all-available | |
662 | (0 "No package outputs are available for some reason.") | |
663 | (1 "A single available package output (that's strange).") | |
664 | (many "%d available package outputs." count)) | |
665 | (newest-available | |
666 | (0 "No package outputs are available for some reason.") | |
667 | (1 "A single newest available package output (that's strange).") | |
668 | (many "%d newest available package outputs." count)) | |
669 | (installed | |
670 | (0 "No installed package outputs.") | |
671 | (1 "A single package output installed.") | |
672 | (many "%d package outputs installed." count)) | |
673 | (obsolete | |
674 | (0 "No obsolete package outputs.") | |
675 | (1 "A single obsolete package output.") | |
676 | (many "%d obsolete package outputs." count)) | |
677 | (generation | |
678 | (0 "No package outputs installed in generation %d." val) | |
679 | (1 "A single package output installed in generation %d." val) | |
680 | (many "%d package outputs installed in generation %d." count val))) | |
457f60fa AK |
681 | (generation |
682 | (id | |
683 | (0 "Generations not found.") | |
684 | (1 "") | |
685 | (many "%d generations." count)) | |
686 | (last | |
687 | (0 "No available generations.") | |
688 | (1 "The last generation.") | |
689 | (many "%d last generations." count)) | |
690 | (all | |
691 | (0 "No available generations.") | |
692 | (1 "A single available generation.") | |
189cea27 AK |
693 | (many "%d available generations." count)) |
694 | (time | |
695 | (0 "Generations not found.") | |
696 | (1 "A single generation matching time period.") | |
697 | (many "%d generations matching time period." count))))) | |
457f60fa AK |
698 | |
699 | (defun guix-result-message (entries entry-type search-type search-vals) | |
700 | "Display an appropriate message after displaying ENTRIES." | |
701 | (let* ((val (car search-vals)) | |
702 | (count (length entries)) | |
703 | (count-key (if (> count 1) 'many count)) | |
704 | (msg-spec (guix-get-key-val guix-messages | |
705 | entry-type search-type count-key)) | |
706 | (format (car msg-spec)) | |
707 | (args (cdr msg-spec))) | |
708 | (mapc (lambda (subst) | |
709 | (setq args (cl-substitute (car subst) (cdr subst) args))) | |
710 | (list (cons count 'count) | |
711 | (cons val 'val))) | |
712 | (apply #'message format args))) | |
713 | ||
714 | \f | |
457f60fa AK |
715 | ;;; Actions on packages and generations |
716 | ||
b497a85b AK |
717 | (defface guix-operation-option-key |
718 | '((t :inherit font-lock-warning-face)) | |
719 | "Face used for the keys of operation options." | |
720 | :group 'guix) | |
721 | ||
457f60fa AK |
722 | (defcustom guix-operation-confirm t |
723 | "If nil, do not prompt to confirm an operation." | |
724 | :type 'boolean | |
725 | :group 'guix) | |
726 | ||
727 | (defcustom guix-use-substitutes t | |
728 | "If non-nil, use substitutes for the Guix packages." | |
729 | :type 'boolean | |
730 | :group 'guix) | |
731 | ||
732 | (defvar guix-dry-run nil | |
733 | "If non-nil, do not perform the real actions, just simulate.") | |
734 | ||
735 | (defvar guix-temp-buffer-name " *Guix temp*" | |
736 | "Name of a buffer used for displaying info before executing operation.") | |
737 | ||
b497a85b AK |
738 | (defvar guix-operation-option-true-string "yes" |
739 | "String displayed in the mode-line when operation option is t.") | |
740 | ||
741 | (defvar guix-operation-option-false-string "no " | |
742 | "String displayed in the mode-line when operation option is nil.") | |
743 | ||
744 | (defvar guix-operation-option-separator " | " | |
745 | "String used in the mode-line to separate operation options.") | |
746 | ||
747 | (defvar guix-operation-options | |
748 | '((?s "substitutes" guix-use-substitutes) | |
749 | (?d "dry-run" guix-dry-run)) | |
750 | "List of available operation options. | |
751 | Each element of the list has a form: | |
752 | ||
753 | (KEY NAME VARIABLE) | |
754 | ||
755 | KEY is a character that may be pressed during confirmation to | |
756 | toggle the option. | |
757 | NAME is a string displayed in the mode-line. | |
758 | VARIABLE is a name of an option variable.") | |
759 | ||
760 | (defun guix-operation-option-by-key (key) | |
761 | "Return operation option by KEY (character)." | |
762 | (assq key guix-operation-options)) | |
763 | ||
764 | (defun guix-operation-option-key (option) | |
765 | "Return key (character) of the operation OPTION." | |
766 | (car option)) | |
767 | ||
768 | (defun guix-operation-option-name (option) | |
769 | "Return name of the operation OPTION." | |
770 | (nth 1 option)) | |
771 | ||
772 | (defun guix-operation-option-variable (option) | |
773 | "Return name of the variable of the operation OPTION." | |
774 | (nth 2 option)) | |
775 | ||
776 | (defun guix-operation-option-value (option) | |
777 | "Return boolean value of the operation OPTION." | |
778 | (symbol-value (guix-operation-option-variable option))) | |
779 | ||
780 | (defun guix-operation-option-string-value (option) | |
781 | "Convert boolean value of the operation OPTION to string and return it." | |
782 | (if (guix-operation-option-value option) | |
783 | guix-operation-option-true-string | |
784 | guix-operation-option-false-string)) | |
785 | ||
23459fa5 AK |
786 | (defun guix-process-package-actions (profile actions |
787 | &optional operation-buffer) | |
788 | "Process package ACTIONS on PROFILE. | |
457f60fa AK |
789 | Each action is a list of the form: |
790 | ||
791 | (ACTION-TYPE PACKAGE-SPEC ...) | |
792 | ||
793 | ACTION-TYPE is one of the following symbols: `install', | |
794 | `upgrade', `remove'/`delete'. | |
795 | PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." | |
796 | (let (install upgrade remove) | |
797 | (mapc (lambda (action) | |
798 | (let ((action-type (car action)) | |
799 | (specs (cdr action))) | |
800 | (cl-case action-type | |
801 | (install (setq install (append install specs))) | |
802 | (upgrade (setq upgrade (append upgrade specs))) | |
803 | ((remove delete) (setq remove (append remove specs)))))) | |
804 | actions) | |
805 | (when (guix-continue-package-operation-p | |
23459fa5 | 806 | profile |
457f60fa AK |
807 | :install install :upgrade upgrade :remove remove) |
808 | (guix-eval-in-repl | |
809 | (guix-make-guile-expression | |
23459fa5 | 810 | 'process-package-actions profile |
457f60fa AK |
811 | :install install :upgrade upgrade :remove remove |
812 | :use-substitutes? (or guix-use-substitutes 'f) | |
49d758d2 AK |
813 | :dry-run? (or guix-dry-run 'f)) |
814 | (and (not guix-dry-run) operation-buffer))))) | |
457f60fa | 815 | |
23459fa5 AK |
816 | (cl-defun guix-continue-package-operation-p (profile |
817 | &key install upgrade remove) | |
457f60fa AK |
818 | "Return non-nil if a package operation should be continued. |
819 | Ask a user if needed (see `guix-operation-confirm'). | |
820 | INSTALL, UPGRADE, REMOVE are 'package action specifications'. | |
821 | See `guix-process-package-actions' for details." | |
822 | (or (null guix-operation-confirm) | |
823 | (let* ((entries (guix-get-entries | |
23459fa5 | 824 | profile 'package 'id |
81b339fe AK |
825 | (append (mapcar #'car install) |
826 | (mapcar #'car upgrade) | |
827 | (mapcar #'car remove)) | |
457f60fa AK |
828 | '(id name version location))) |
829 | (install-strings (guix-get-package-strings install entries)) | |
830 | (upgrade-strings (guix-get-package-strings upgrade entries)) | |
831 | (remove-strings (guix-get-package-strings remove entries))) | |
832 | (if (or install-strings upgrade-strings remove-strings) | |
833 | (let ((buf (get-buffer-create guix-temp-buffer-name))) | |
834 | (with-current-buffer buf | |
835 | (setq-local cursor-type nil) | |
836 | (setq buffer-read-only nil) | |
837 | (erase-buffer) | |
23459fa5 | 838 | (insert "Profile: " profile "\n\n") |
457f60fa AK |
839 | (guix-insert-package-strings install-strings "install") |
840 | (guix-insert-package-strings upgrade-strings "upgrade") | |
841 | (guix-insert-package-strings remove-strings "remove") | |
842 | (let ((win (temp-buffer-window-show | |
843 | buf | |
844 | '((display-buffer-reuse-window | |
845 | display-buffer-at-bottom) | |
846 | (window-height . fit-window-to-buffer))))) | |
b497a85b | 847 | (prog1 (guix-operation-prompt) |
457f60fa AK |
848 | (quit-window nil win))))) |
849 | (message "Nothing to be done. If the REPL was restarted, information is not up-to-date.") | |
850 | nil)))) | |
851 | ||
852 | (defun guix-get-package-strings (specs entries) | |
853 | "Return short package descriptions for performing package actions. | |
854 | See `guix-process-package-actions' for the meaning of SPECS. | |
855 | ENTRIES is a list of package entries to get info about packages." | |
856 | (delq nil | |
857 | (mapcar | |
858 | (lambda (spec) | |
859 | (let* ((id (car spec)) | |
860 | (outputs (cdr spec)) | |
861 | (entry (guix-get-entry-by-id id entries))) | |
862 | (when entry | |
863 | (let ((location (guix-get-key-val entry 'location))) | |
864 | (concat (guix-get-full-name entry) | |
865 | (when outputs | |
866 | (concat ":" | |
867 | (mapconcat #'identity outputs ","))) | |
868 | (when location | |
869 | (concat "\t(" location ")"))))))) | |
870 | specs))) | |
871 | ||
872 | (defun guix-insert-package-strings (strings action) | |
873 | "Insert information STRINGS at point for performing package ACTION." | |
874 | (when strings | |
2e269860 | 875 | (insert "Package(s) to " (propertize action 'face 'bold) ":\n") |
457f60fa AK |
876 | (mapc (lambda (str) |
877 | (insert " " str "\n")) | |
878 | strings) | |
879 | (insert "\n"))) | |
880 | ||
b497a85b AK |
881 | (defun guix-operation-prompt () |
882 | "Prompt a user for continuing the current package operation. | |
883 | Return non-nil, if the operation should be continued; nil otherwise." | |
884 | (let* ((option-keys (mapcar #'guix-operation-option-key | |
885 | guix-operation-options)) | |
886 | (keys (append '(?y ?n) option-keys)) | |
887 | (prompt (concat (propertize "Continue operation?" | |
888 | 'face 'minibuffer-prompt) | |
889 | " (" | |
890 | (mapconcat | |
891 | (lambda (key) | |
892 | (propertize (string key) | |
893 | 'face 'guix-operation-option-key)) | |
894 | keys | |
895 | ", ") | |
896 | ") "))) | |
897 | (prog1 (guix-operation-prompt-1 prompt keys) | |
898 | ;; Clear the minibuffer after prompting. | |
899 | (message "")))) | |
900 | ||
901 | (defun guix-operation-prompt-1 (prompt keys) | |
902 | "This function is internal for `guix-operation-prompt'." | |
903 | (guix-operation-set-mode-line) | |
904 | (let ((key (read-char-choice prompt (cons ?\C-g keys) t))) | |
905 | (cl-case key | |
906 | (?y t) | |
907 | ((?n ?\C-g) nil) | |
908 | (t (let* ((option (guix-operation-option-by-key key)) | |
909 | (var (guix-operation-option-variable option))) | |
910 | (set var (not (symbol-value var))) | |
911 | (guix-operation-prompt-1 prompt keys)))))) | |
912 | ||
913 | (defun guix-operation-set-mode-line () | |
914 | "Display operation options in the mode-line of the current buffer." | |
915 | (setq mode-line-format | |
916 | (concat (propertize " Options: " | |
917 | 'face 'mode-line-buffer-id) | |
918 | (mapconcat | |
919 | (lambda (option) | |
920 | (let ((key (guix-operation-option-key option)) | |
921 | (name (guix-operation-option-name option)) | |
922 | (val (guix-operation-option-string-value option))) | |
923 | (concat name | |
924 | " (" | |
925 | (propertize (string key) | |
926 | 'face 'guix-operation-option-key) | |
927 | "): " val))) | |
928 | guix-operation-options | |
929 | guix-operation-option-separator))) | |
930 | (force-mode-line-update)) | |
931 | ||
23459fa5 AK |
932 | (defun guix-delete-generations (profile generations |
933 | &optional operation-buffer) | |
934 | "Delete GENERATIONS from PROFILE. | |
cb6a5c71 AK |
935 | Each element from GENERATIONS is a generation number." |
936 | (when (or (not guix-operation-confirm) | |
23459fa5 AK |
937 | (y-or-n-p |
938 | (let ((count (length generations))) | |
939 | (if (> count 1) | |
940 | (format "Delete %d generations from profile '%s'? " | |
941 | count profile) | |
942 | (format "Delete generation %d from profile '%s'? " | |
943 | (car generations) profile))))) | |
cb6a5c71 AK |
944 | (guix-eval-in-repl |
945 | (guix-make-guile-expression | |
23459fa5 | 946 | 'delete-generations* profile generations) |
49d758d2 | 947 | operation-buffer))) |
cb6a5c71 | 948 | |
23459fa5 AK |
949 | (defun guix-switch-to-generation (profile generation |
950 | &optional operation-buffer) | |
951 | "Switch PROFILE to GENERATION." | |
af874238 | 952 | (when (or (not guix-operation-confirm) |
23459fa5 AK |
953 | (y-or-n-p (format "Switch profile '%s' to generation %d? " |
954 | profile generation))) | |
af874238 AK |
955 | (guix-eval-in-repl |
956 | (guix-make-guile-expression | |
23459fa5 | 957 | 'switch-to-generation profile generation) |
49d758d2 | 958 | operation-buffer))) |
af874238 | 959 | |
457f60fa AK |
960 | (provide 'guix-base) |
961 | ||
962 | ;;; guix-base.el ends here |