Commit | Line | Data |
---|---|---|
457f60fa AK |
1 | ;;; guix-list.el --- List buffers for displaying entries -*- lexical-binding: t -*- |
2 | ||
51dac383 | 3 | ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> |
457f60fa AK |
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 a list-like buffer for displaying information | |
23 | ;; about Guix packages and generations. | |
24 | ||
25 | ;;; Code: | |
26 | ||
27 | (require 'cl-lib) | |
28 | (require 'tabulated-list) | |
29 | (require 'guix-info) | |
457f60fa AK |
30 | (require 'guix-base) |
31 | (require 'guix-utils) | |
32 | ||
33 | (defgroup guix-list nil | |
34 | "General settings for list buffers." | |
35 | :prefix "guix-list-" | |
36 | :group 'guix) | |
37 | ||
46e17df6 AK |
38 | (defgroup guix-list-faces nil |
39 | "Faces for list buffers." | |
40 | :group 'guix-list | |
41 | :group 'guix-faces) | |
42 | ||
457f60fa AK |
43 | (defface guix-list-file-path |
44 | '((t :inherit guix-info-file-path)) | |
45 | "Face used for file paths." | |
46e17df6 | 46 | :group 'guix-list-faces) |
457f60fa AK |
47 | |
48 | (defcustom guix-list-describe-warning-count 10 | |
49 | "The maximum number of entries for describing without a warning. | |
50 | If a user wants to describe more than this number of marked | |
51 | entries, he will be prompted for confirmation." | |
52 | :type 'integer | |
53 | :group 'guix-list) | |
54 | ||
55 | (defvar guix-list-column-format | |
56 | `((package | |
57 | (name 20 t) | |
58 | (version 10 nil) | |
59 | (outputs 13 t) | |
60 | (installed 13 t) | |
61 | (synopsis 30 nil)) | |
a54a237b AK |
62 | (output |
63 | (name 20 t) | |
64 | (version 10 nil) | |
65 | (output 9 t) | |
66 | (installed 12 t) | |
67 | (synopsis 30 nil)) | |
457f60fa AK |
68 | (generation |
69 | (number 5 | |
70 | ,(lambda (a b) (guix-list-sort-numerically 0 a b)) | |
71 | :right-align t) | |
c2379b3c | 72 | (current 10 t) |
457f60fa AK |
73 | (time 20 t) |
74 | (path 30 t))) | |
75 | "Columns displayed in list buffers. | |
76 | Each element of the list has a form: | |
77 | ||
78 | (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...)) | |
79 | ||
80 | PARAM is the name of an entry parameter of ENTRY-TYPE. For the | |
81 | meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.") | |
82 | ||
83 | (defvar guix-list-column-titles | |
84 | '((generation | |
85 | (number . "N."))) | |
86 | "Column titles for list buffers. | |
87 | Has the same structure as `guix-param-titles', but titles from | |
88 | this list have a priority.") | |
89 | ||
90 | (defvar guix-list-column-value-methods | |
91 | '((package | |
92 | (name . guix-package-list-get-name) | |
93 | (synopsis . guix-list-get-one-line) | |
94 | (description . guix-list-get-one-line) | |
95 | (installed . guix-package-list-get-installed-outputs)) | |
a54a237b AK |
96 | (output |
97 | (name . guix-package-list-get-name) | |
98 | (synopsis . guix-list-get-one-line) | |
99 | (description . guix-list-get-one-line)) | |
457f60fa | 100 | (generation |
c2379b3c AK |
101 | (current . guix-generation-list-get-current) |
102 | (time . guix-list-get-time) | |
103 | (path . guix-list-get-file-path))) | |
457f60fa AK |
104 | "Methods for inserting parameter values in columns. |
105 | Each element of the list has a form: | |
106 | ||
107 | (ENTRY-TYPE . ((PARAM . FUN) ...)) | |
108 | ||
109 | PARAM is the name of an entry parameter of ENTRY-TYPE. | |
110 | ||
111 | FUN is a function returning a value that will be inserted. The | |
112 | function is called with 2 arguments: the first one is the value | |
113 | of the parameter; the second argument is an entry info (alist of | |
114 | parameters and their values).") | |
115 | ||
116 | (defun guix-list-get-param-title (entry-type param) | |
117 | "Return title of an ENTRY-TYPE entry parameter PARAM." | |
51dac383 AK |
118 | (or (guix-assq-value guix-list-column-titles |
119 | entry-type param) | |
457f60fa AK |
120 | (guix-get-param-title entry-type param))) |
121 | ||
122 | (defun guix-list-get-column-format (entry-type) | |
123 | "Return column format for ENTRY-TYPE." | |
51dac383 | 124 | (guix-assq-value guix-list-column-format entry-type)) |
457f60fa AK |
125 | |
126 | (defun guix-list-get-displayed-params (entry-type) | |
127 | "Return list of parameters of ENTRY-TYPE that should be displayed." | |
128 | (mapcar #'car | |
129 | (guix-list-get-column-format entry-type))) | |
130 | ||
131 | (defun guix-list-get-sort-key (entry-type param &optional invert) | |
132 | "Return suitable sort key for `tabulated-list-sort-key'. | |
133 | Define column title by ENTRY-TYPE and PARAM. If INVERT is | |
134 | non-nil, invert the sort." | |
135 | (when (memq param (guix-list-get-displayed-params entry-type)) | |
136 | (cons (guix-list-get-param-title entry-type param) invert))) | |
137 | ||
138 | (defun guix-list-sort-numerically (column a b) | |
139 | "Compare COLUMN of tabulated entries A and B numerically. | |
140 | It is a sort predicate for `tabulated-list-format'. | |
141 | Return non-nil, if B is bigger than A." | |
142 | (cl-flet ((num (entry) | |
143 | (string-to-number (aref (cadr entry) column)))) | |
144 | (> (num b) (num a)))) | |
145 | ||
146 | (defun guix-list-make-tabulated-vector (entry-type fun) | |
147 | "Call FUN on each column specification for ENTRY-TYPE. | |
148 | ||
149 | FUN is called with 2 argument: parameter name and column | |
150 | specification (see `guix-list-column-format'). | |
151 | ||
152 | Return a vector made of values of FUN calls." | |
153 | (apply #'vector | |
154 | (mapcar (lambda (col-spec) | |
155 | (funcall fun (car col-spec) (cdr col-spec))) | |
156 | (guix-list-get-column-format entry-type)))) | |
157 | ||
158 | (defun guix-list-get-list-format (entry-type) | |
159 | "Return ENTRY-TYPE list specification for `tabulated-list-format'." | |
160 | (guix-list-make-tabulated-vector | |
161 | entry-type | |
162 | (lambda (param spec) | |
163 | (cons (guix-list-get-param-title entry-type param) | |
164 | spec)))) | |
165 | ||
166 | (defun guix-list-insert-entries (entries entry-type) | |
167 | "Display ENTRIES of ENTRY-TYPE in the current list buffer. | |
168 | ENTRIES should have a form of `guix-entries'." | |
169 | (setq tabulated-list-entries | |
170 | (guix-list-get-tabulated-entries entries entry-type)) | |
171 | (tabulated-list-print)) | |
172 | ||
173 | (defun guix-list-get-tabulated-entries (entries entry-type) | |
174 | "Return list of values of ENTRY-TYPE for `tabulated-list-entries'. | |
175 | Values are taken from ENTRIES which should have the form of | |
176 | `guix-entries'." | |
177 | (mapcar (lambda (entry) | |
51dac383 | 178 | (list (guix-assq-value entry 'id) |
457f60fa AK |
179 | (guix-list-get-tabulated-entry entry entry-type))) |
180 | entries)) | |
181 | ||
182 | (defun guix-list-get-tabulated-entry (entry entry-type) | |
183 | "Return array of values for `tabulated-list-entries'. | |
184 | Parameters are taken from ENTRY of ENTRY-TYPE." | |
185 | (guix-list-make-tabulated-vector | |
186 | entry-type | |
187 | (lambda (param _) | |
51dac383 AK |
188 | (let ((val (guix-assq-value entry param)) |
189 | (fun (guix-assq-value guix-list-column-value-methods | |
190 | entry-type param))) | |
abc5b829 | 191 | (if fun |
457f60fa AK |
192 | (funcall fun val entry) |
193 | (guix-get-string val)))))) | |
194 | ||
abc5b829 AK |
195 | (defun guix-list-get-one-line (val &optional _) |
196 | "Return one-line string from a multi-line string VAL. | |
197 | VAL may be nil." | |
198 | (if val | |
199 | (guix-get-one-line val) | |
200 | (guix-get-string nil))) | |
457f60fa AK |
201 | |
202 | (defun guix-list-get-time (seconds &optional _) | |
203 | "Return formatted time string from SECONDS." | |
204 | (guix-get-time-string seconds)) | |
205 | ||
206 | (defun guix-list-get-file-path (path &optional _) | |
207 | "Return PATH button specification for `tabulated-list-entries'." | |
208 | (list path | |
209 | 'face 'guix-list-file-path | |
210 | 'action (lambda (btn) (find-file (button-label btn))) | |
211 | 'follow-link t | |
212 | 'help-echo "Find file")) | |
213 | ||
214 | (defun guix-list-current-id () | |
215 | "Return ID of the current entry." | |
216 | (or (tabulated-list-get-id) | |
217 | (user-error "No entry here"))) | |
218 | ||
219 | (defun guix-list-current-entry () | |
220 | "Return alist of the current entry info." | |
221 | (guix-get-entry-by-id (guix-list-current-id) guix-entries)) | |
222 | ||
6a8c9545 AK |
223 | (defun guix-list-current-package-id () |
224 | "Return ID of the current package." | |
225 | (cl-ecase major-mode | |
226 | (guix-package-list-mode | |
227 | (guix-list-current-id)) | |
228 | (guix-output-list-mode | |
51dac383 | 229 | (guix-assq-value (guix-list-current-entry) 'package-id)))) |
6a8c9545 | 230 | |
457f60fa AK |
231 | (defun guix-list-for-each-line (fun &rest args) |
232 | "Call FUN with ARGS for each entry line." | |
233 | (or (derived-mode-p 'guix-list-mode) | |
234 | (error "The current buffer is not in Guix List mode")) | |
235 | (save-excursion | |
236 | (goto-char (point-min)) | |
237 | (while (not (eobp)) | |
238 | (apply fun args) | |
239 | (forward-line)))) | |
240 | ||
241 | (defun guix-list-fold-lines (fun init) | |
242 | "Fold over entry lines in the current list buffer. | |
243 | Call FUN with RESULT as argument for each line, using INIT as | |
244 | the initial value of RESULT. Return the final result." | |
245 | (let ((res init)) | |
246 | (guix-list-for-each-line | |
247 | (lambda () (setq res (funcall fun res)))) | |
248 | res)) | |
249 | ||
250 | \f | |
251 | ;;; Marking and sorting | |
252 | ||
253 | (defvar-local guix-list-marked nil | |
254 | "List of the marked entries. | |
255 | Each element of the list has a form: | |
256 | ||
257 | (ID MARK-NAME . ARGS) | |
258 | ||
259 | ID is an entry ID. | |
260 | MARK-NAME is a symbol from `guix-list-mark-alist'. | |
261 | ARGS is a list of additional values.") | |
262 | ||
263 | (defvar guix-list-mark-alist | |
264 | '((empty . ?\s) | |
265 | (general . ?*)) | |
266 | "Alist of available mark names and mark characters.") | |
267 | ||
268 | (defsubst guix-list-get-mark (name) | |
269 | "Return mark character by its NAME." | |
51dac383 | 270 | (or (guix-assq-value guix-list-mark-alist name) |
457f60fa AK |
271 | (error "Mark '%S' not found" name))) |
272 | ||
273 | (defsubst guix-list-get-mark-string (name) | |
274 | "Return mark string by its NAME." | |
275 | (string (guix-list-get-mark name))) | |
276 | ||
277 | (defun guix-list-current-mark () | |
278 | "Return mark character of the current line." | |
279 | (char-after (line-beginning-position))) | |
280 | ||
281 | (defun guix-list-get-marked (&rest mark-names) | |
282 | "Return list of specs of entries marked with any mark from MARK-NAMES. | |
283 | Entry specs are elements from `guix-list-marked' list. | |
284 | If MARK-NAMES are not specified, use all marks from | |
285 | `guix-list-mark-alist' except the `empty' one." | |
286 | (or mark-names | |
287 | (setq mark-names | |
288 | (delq 'empty | |
289 | (mapcar #'car guix-list-mark-alist)))) | |
290 | (cl-remove-if-not (lambda (assoc) | |
291 | (memq (cadr assoc) mark-names)) | |
292 | guix-list-marked)) | |
293 | ||
294 | (defun guix-list-get-marked-args (mark-name) | |
295 | "Return list of (ID . ARGS) elements from lines marked with MARK-NAME. | |
296 | See `guix-list-marked' for the meaning of ARGS." | |
297 | (mapcar (lambda (spec) | |
298 | (let ((id (car spec)) | |
299 | (args (cddr spec))) | |
300 | (cons id args))) | |
301 | (guix-list-get-marked mark-name))) | |
302 | ||
303 | (defun guix-list-get-marked-id-list (&rest mark-names) | |
304 | "Return list of IDs of entries marked with any mark from MARK-NAMES. | |
305 | See `guix-list-get-marked' for details." | |
306 | (mapcar #'car (apply #'guix-list-get-marked mark-names))) | |
307 | ||
578b98da | 308 | (defun guix-list--mark (mark-name &optional advance &rest args) |
457f60fa AK |
309 | "Put a mark on the current line. |
310 | Also add the current entry to `guix-list-marked' using its ID and ARGS. | |
311 | MARK-NAME is a symbol from `guix-list-mark-alist'. | |
578b98da | 312 | If ADVANCE is non-nil, move forward by one line after marking." |
457f60fa AK |
313 | (let ((id (guix-list-current-id))) |
314 | (if (eq mark-name 'empty) | |
315 | (setq guix-list-marked (assq-delete-all id guix-list-marked)) | |
316 | (let ((assoc (assq id guix-list-marked)) | |
317 | (val (cons mark-name args))) | |
318 | (if assoc | |
319 | (setcdr assoc val) | |
320 | (push (cons id val) guix-list-marked))))) | |
321 | (tabulated-list-put-tag (guix-list-get-mark-string mark-name) | |
322 | advance)) | |
323 | ||
578b98da AK |
324 | (defun guix-list-mark (&optional arg) |
325 | "Mark the current line and move to the next line. | |
326 | With ARG, mark all lines." | |
327 | (interactive "P") | |
328 | (if arg | |
329 | (guix-list-mark-all) | |
330 | (guix-list--mark 'general t))) | |
331 | ||
332 | (defun guix-list-mark-all (&optional mark-name) | |
457f60fa AK |
333 | "Mark all lines with MARK-NAME mark. |
334 | MARK-NAME is a symbol from `guix-list-mark-alist'. | |
335 | Interactively, put a general mark on all lines." | |
578b98da AK |
336 | (interactive) |
337 | (or mark-name (setq mark-name 'general)) | |
338 | (guix-list-for-each-line #'guix-list--mark mark-name)) | |
457f60fa | 339 | |
91cc37a1 AK |
340 | (defun guix-list-unmark (&optional arg) |
341 | "Unmark the current line and move to the next line. | |
342 | With ARG, unmark all lines." | |
343 | (interactive "P") | |
344 | (if arg | |
345 | (guix-list-unmark-all) | |
578b98da | 346 | (guix-list--mark 'empty t))) |
457f60fa AK |
347 | |
348 | (defun guix-list-unmark-backward () | |
349 | "Move up one line and unmark it." | |
350 | (interactive) | |
351 | (forward-line -1) | |
578b98da | 352 | (guix-list--mark 'empty)) |
457f60fa AK |
353 | |
354 | (defun guix-list-unmark-all () | |
355 | "Unmark all lines." | |
356 | (interactive) | |
357 | (guix-list-mark-all 'empty)) | |
358 | ||
359 | (defun guix-list-restore-marks () | |
360 | "Put marks according to `guix-list-mark-alist'." | |
361 | (guix-list-for-each-line | |
362 | (lambda () | |
51dac383 AK |
363 | (let ((mark-name (car (guix-assq-value guix-list-marked |
364 | (guix-list-current-id))))) | |
457f60fa AK |
365 | (tabulated-list-put-tag |
366 | (guix-list-get-mark-string (or mark-name 'empty))))))) | |
367 | ||
368 | (defun guix-list-sort (&optional n) | |
369 | "Sort guix list entries by the column at point. | |
370 | With a numeric prefix argument N, sort the Nth column. | |
371 | Same as `tabulated-list-sort', but also restore marks after sorting." | |
372 | (interactive "P") | |
373 | (tabulated-list-sort n) | |
374 | (guix-list-restore-marks)) | |
375 | ||
376 | \f | |
377 | (defvar guix-list-mode-map | |
378 | (let ((map (make-sparse-keymap))) | |
74cc6737 AK |
379 | (set-keymap-parent |
380 | map (make-composed-keymap guix-root-map | |
381 | tabulated-list-mode-map)) | |
dfeb0239 | 382 | (define-key map (kbd "RET") 'guix-list-describe) |
457f60fa AK |
383 | (define-key map (kbd "m") 'guix-list-mark) |
384 | (define-key map (kbd "*") 'guix-list-mark) | |
457f60fa | 385 | (define-key map (kbd "u") 'guix-list-unmark) |
457f60fa AK |
386 | (define-key map (kbd "DEL") 'guix-list-unmark-backward) |
387 | (define-key map [remap tabulated-list-sort] 'guix-list-sort) | |
388 | map) | |
389 | "Parent keymap for list buffers.") | |
390 | ||
391 | (define-derived-mode guix-list-mode tabulated-list-mode "Guix-List" | |
392 | "Parent mode for displaying information in list buffers." | |
393 | (setq tabulated-list-padding 2)) | |
394 | ||
395 | (defmacro guix-list-define-entry-type (entry-type &rest args) | |
396 | "Define common stuff for displaying ENTRY-TYPE entries in list buffers. | |
397 | ||
398 | Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The | |
399 | following keywords are available: | |
400 | ||
401 | - `:sort-key' - default sort key for the tabulated list buffer. | |
402 | ||
403 | - `:invert-sort' - if non-nil, invert initial sort. | |
404 | ||
405 | - `:marks' - default value for the defined | |
406 | `guix-ENTRY-TYPE-mark-alist' variable. | |
407 | ||
408 | This macro defines the following functions: | |
409 | ||
457f60fa AK |
410 | - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark |
411 | specified in `:marks' argument." | |
412 | (let* ((entry-type-str (symbol-name entry-type)) | |
457f60fa AK |
413 | (prefix (concat "guix-" entry-type-str "-list")) |
414 | (mode-str (concat prefix "-mode")) | |
415 | (init-fun (intern (concat prefix "-mode-initialize"))) | |
457f60fa AK |
416 | (marks-var (intern (concat prefix "-mark-alist"))) |
417 | (marks-val nil) | |
418 | (sort-key nil) | |
419 | (invert-sort nil)) | |
420 | ||
421 | ;; Process the keyword args. | |
422 | (while (keywordp (car args)) | |
423 | (pcase (pop args) | |
424 | (`:sort-key (setq sort-key (pop args))) | |
425 | (`:invert-sort (setq invert-sort (pop args))) | |
426 | (`:marks (setq marks-val (pop args))) | |
427 | (_ (pop args)))) | |
428 | ||
429 | `(progn | |
430 | (defvar ,marks-var ',marks-val | |
431 | ,(concat "Alist of additional marks for `" mode-str "'.\n" | |
432 | "Marks from this list are added to `guix-list-mark-alist'.")) | |
433 | ||
434 | ,@(mapcar (lambda (mark-spec) | |
435 | (let* ((mark-name (car mark-spec)) | |
436 | (mark-name-str (symbol-name mark-name))) | |
437 | `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) () | |
438 | ,(concat "Put '" mark-name-str "' mark and move to the next line.\n" | |
439 | "Also add the current entry to `guix-list-marked'.") | |
440 | (interactive) | |
578b98da | 441 | (guix-list--mark ',mark-name t)))) |
457f60fa AK |
442 | marks-val) |
443 | ||
457f60fa AK |
444 | (defun ,init-fun () |
445 | ,(concat "Initial settings for `" mode-str "'.") | |
446 | ,(when sort-key | |
447 | `(setq tabulated-list-sort-key | |
448 | (guix-list-get-sort-key | |
449 | ',entry-type ',sort-key ,invert-sort))) | |
450 | (setq tabulated-list-format | |
451 | (guix-list-get-list-format ',entry-type)) | |
452 | (setq-local guix-list-mark-alist | |
453 | (append guix-list-mark-alist ,marks-var)) | |
454 | (tabulated-list-init-header))))) | |
455 | ||
456 | (put 'guix-list-define-entry-type 'lisp-indent-function 'defun) | |
457 | ||
a54a237b AK |
458 | (defun guix-list-describe-maybe (entry-type ids) |
459 | "Describe ENTRY-TYPE entries in info buffer using list of IDS." | |
460 | (let ((count (length ids))) | |
461 | (when (or (<= count guix-list-describe-warning-count) | |
462 | (y-or-n-p (format "Do you really want to describe %d entries? " | |
463 | count))) | |
23459fa5 AK |
464 | (apply #'guix-get-show-entries |
465 | guix-profile 'info entry-type 'id ids)))) | |
a54a237b | 466 | |
dfeb0239 AK |
467 | (defun guix-list-describe (&optional arg) |
468 | "Describe entries marked with a general mark. | |
469 | If no entries are marked, describe the current entry. | |
470 | With prefix (if ARG is non-nil), describe entries marked with any mark." | |
471 | (interactive "P") | |
a54a237b AK |
472 | (let ((ids (or (apply #'guix-list-get-marked-id-list |
473 | (unless arg '(general))) | |
474 | (list (guix-list-current-id))))) | |
475 | (guix-list-describe-maybe guix-entry-type ids))) | |
dfeb0239 | 476 | |
6248e326 AK |
477 | (defun guix-list-edit-package () |
478 | "Go to the location of the current package." | |
479 | (interactive) | |
eb097f36 | 480 | (guix-edit (guix-list-current-package-id))) |
6248e326 | 481 | |
457f60fa AK |
482 | \f |
483 | ;;; Displaying packages | |
484 | ||
485 | (guix-define-buffer-type list package) | |
486 | ||
487 | (guix-list-define-entry-type package | |
488 | :sort-key name | |
489 | :marks ((install . ?I) | |
490 | (upgrade . ?U) | |
491 | (delete . ?D))) | |
492 | ||
8ed08c76 AK |
493 | (defface guix-package-list-installed |
494 | '((t :inherit guix-package-info-installed-outputs)) | |
495 | "Face used if there are installed outputs for the current package." | |
46e17df6 | 496 | :group 'guix-package-list-faces) |
8ed08c76 | 497 | |
457f60fa AK |
498 | (defface guix-package-list-obsolete |
499 | '((t :inherit guix-package-info-obsolete)) | |
500 | "Face used if a package is obsolete." | |
46e17df6 | 501 | :group 'guix-package-list-faces) |
457f60fa AK |
502 | |
503 | (defcustom guix-package-list-generation-marking-enabled nil | |
504 | "If non-nil, allow putting marks in a list with 'generation packages'. | |
505 | ||
506 | By default this is disabled, because it may be confusing. For | |
507 | example a package is installed in some generation, so a user can | |
508 | mark it for deletion in the list of packages from this | |
509 | generation, but the package may not be installed in the latest | |
510 | generation, so actually it cannot be deleted. | |
511 | ||
512 | If you managed to understand the explanation above or if you | |
513 | really know what you do or if you just don't care, you can set | |
514 | this variable to t. It should not do much harm anyway (most | |
515 | likely)." | |
516 | :type 'boolean | |
517 | :group 'guix-package-list) | |
518 | ||
519 | (let ((map guix-package-list-mode-map)) | |
6248e326 | 520 | (define-key map (kbd "e") 'guix-list-edit-package) |
457f60fa AK |
521 | (define-key map (kbd "x") 'guix-package-list-execute) |
522 | (define-key map (kbd "i") 'guix-package-list-mark-install) | |
91cc37a1 AK |
523 | (define-key map (kbd "d") 'guix-package-list-mark-delete) |
524 | (define-key map (kbd "U") 'guix-package-list-mark-upgrade) | |
525 | (define-key map (kbd "^") 'guix-package-list-mark-upgrades)) | |
457f60fa AK |
526 | |
527 | (defun guix-package-list-get-name (name entry) | |
528 | "Return NAME of the package ENTRY. | |
8ed08c76 AK |
529 | Colorize it with `guix-package-list-installed' or |
530 | `guix-package-list-obsolete' if needed." | |
457f60fa | 531 | (guix-get-string name |
51dac383 | 532 | (cond ((guix-assq-value entry 'obsolete) |
8ed08c76 | 533 | 'guix-package-list-obsolete) |
51dac383 | 534 | ((guix-assq-value entry 'installed) |
8ed08c76 | 535 | 'guix-package-list-installed)))) |
457f60fa AK |
536 | |
537 | (defun guix-package-list-get-installed-outputs (installed &optional _) | |
538 | "Return string with outputs from INSTALLED entries." | |
539 | (guix-get-string | |
540 | (mapcar (lambda (entry) | |
51dac383 | 541 | (guix-assq-value entry 'output)) |
457f60fa AK |
542 | installed))) |
543 | ||
544 | (defun guix-package-list-marking-check () | |
545 | "Signal an error if marking is disabled for the current buffer." | |
546 | (when (and (not guix-package-list-generation-marking-enabled) | |
a54a237b AK |
547 | (or (derived-mode-p 'guix-package-list-mode) |
548 | (derived-mode-p 'guix-output-list-mode)) | |
457f60fa AK |
549 | (eq guix-search-type 'generation)) |
550 | (error "Action marks are disabled for lists of 'generation packages'"))) | |
551 | ||
91cc37a1 AK |
552 | (defun guix-package-list-mark-outputs (mark default |
553 | &optional prompt available) | |
554 | "Mark the current package with MARK and move to the next line. | |
555 | If PROMPT is non-nil, use it to ask a user for outputs from | |
556 | AVAILABLE list, otherwise mark all DEFAULT outputs." | |
557 | (let ((outputs (if prompt | |
558 | (guix-completing-read-multiple | |
559 | prompt available nil t) | |
560 | default))) | |
578b98da | 561 | (apply #'guix-list--mark mark t outputs))) |
91cc37a1 | 562 | |
457f60fa AK |
563 | (defun guix-package-list-mark-install (&optional arg) |
564 | "Mark the current package for installation and move to the next line. | |
565 | With ARG, prompt for the outputs to install (several outputs may | |
566 | be separated with \",\")." | |
567 | (interactive "P") | |
568 | (guix-package-list-marking-check) | |
91cc37a1 | 569 | (let* ((entry (guix-list-current-entry)) |
51dac383 | 570 | (all (guix-assq-value entry 'outputs)) |
457f60fa | 571 | (installed (guix-get-installed-outputs entry)) |
91cc37a1 AK |
572 | (available (cl-set-difference all installed :test #'string=))) |
573 | (or available | |
574 | (user-error "This package is already installed")) | |
575 | (guix-package-list-mark-outputs | |
576 | 'install '("out") | |
577 | (and arg "Output(s) to install: ") | |
578 | available))) | |
457f60fa AK |
579 | |
580 | (defun guix-package-list-mark-delete (&optional arg) | |
581 | "Mark the current package for deletion and move to the next line. | |
582 | With ARG, prompt for the outputs to delete (several outputs may | |
583 | be separated with \",\")." | |
584 | (interactive "P") | |
585 | (guix-package-list-marking-check) | |
586 | (let* ((entry (guix-list-current-entry)) | |
587 | (installed (guix-get-installed-outputs entry))) | |
588 | (or installed | |
589 | (user-error "This package is not installed")) | |
91cc37a1 AK |
590 | (guix-package-list-mark-outputs |
591 | 'delete installed | |
592 | (and arg "Output(s) to delete: ") | |
593 | installed))) | |
594 | ||
595 | (defun guix-package-list-mark-upgrade (&optional arg) | |
596 | "Mark the current package for upgrading and move to the next line. | |
597 | With ARG, prompt for the outputs to upgrade (several outputs may | |
598 | be separated with \",\")." | |
599 | (interactive "P") | |
457f60fa | 600 | (guix-package-list-marking-check) |
91cc37a1 AK |
601 | (let* ((entry (guix-list-current-entry)) |
602 | (installed (guix-get-installed-outputs entry))) | |
603 | (or installed | |
457f60fa | 604 | (user-error "This package is not installed")) |
51dac383 | 605 | (when (or (guix-assq-value entry 'obsolete) |
457f60fa | 606 | (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) |
91cc37a1 AK |
607 | (guix-package-list-mark-outputs |
608 | 'upgrade installed | |
609 | (and arg "Output(s) to upgrade: ") | |
610 | installed)))) | |
611 | ||
a54a237b AK |
612 | (defun guix-list-mark-package-upgrades (fun) |
613 | "Mark all obsolete packages for upgrading. | |
614 | Use FUN to perform marking of the current line. FUN should | |
615 | accept an entry as argument." | |
91cc37a1 AK |
616 | (guix-package-list-marking-check) |
617 | (let ((obsolete (cl-remove-if-not | |
618 | (lambda (entry) | |
51dac383 | 619 | (guix-assq-value entry 'obsolete)) |
91cc37a1 AK |
620 | guix-entries))) |
621 | (guix-list-for-each-line | |
622 | (lambda () | |
623 | (let* ((id (guix-list-current-id)) | |
624 | (entry (cl-find-if | |
625 | (lambda (entry) | |
51dac383 | 626 | (equal id (guix-assq-value entry 'id))) |
91cc37a1 AK |
627 | obsolete))) |
628 | (when entry | |
a54a237b | 629 | (funcall fun entry))))))) |
457f60fa | 630 | |
a54a237b AK |
631 | (defun guix-package-list-mark-upgrades () |
632 | "Mark all obsolete packages for upgrading." | |
457f60fa | 633 | (interactive) |
a54a237b AK |
634 | (guix-list-mark-package-upgrades |
635 | (lambda (entry) | |
578b98da | 636 | (apply #'guix-list--mark |
a54a237b AK |
637 | 'upgrade nil |
638 | (guix-get-installed-outputs entry))))) | |
639 | ||
640 | (defun guix-list-execute-package-actions (fun) | |
641 | "Perform actions on the marked packages. | |
642 | Use FUN to define actions suitable for `guix-process-package-actions'. | |
643 | FUN should accept action-type as argument." | |
457f60fa | 644 | (let ((actions (delq nil |
a54a237b | 645 | (mapcar fun '(install delete upgrade))))) |
457f60fa | 646 | (if actions |
23459fa5 AK |
647 | (guix-process-package-actions |
648 | guix-profile actions (current-buffer)) | |
457f60fa AK |
649 | (user-error "No operations specified")))) |
650 | ||
a54a237b AK |
651 | (defun guix-package-list-execute () |
652 | "Perform actions on the marked packages." | |
653 | (interactive) | |
654 | (guix-list-execute-package-actions #'guix-package-list-make-action)) | |
655 | ||
457f60fa AK |
656 | (defun guix-package-list-make-action (action-type) |
657 | "Return action specification for the packages marked with ACTION-TYPE. | |
658 | Return nil, if there are no packages marked with ACTION-TYPE. | |
659 | The specification is suitable for `guix-process-package-actions'." | |
660 | (let ((specs (guix-list-get-marked-args action-type))) | |
661 | (and specs (cons action-type specs)))) | |
662 | ||
663 | \f | |
a54a237b AK |
664 | ;;; Displaying outputs |
665 | ||
666 | (guix-define-buffer-type list output | |
6a8c9545 AK |
667 | :buffer-name "*Guix Package List*" |
668 | :required (package-id)) | |
a54a237b AK |
669 | |
670 | (guix-list-define-entry-type output | |
671 | :sort-key name | |
672 | :marks ((install . ?I) | |
673 | (upgrade . ?U) | |
674 | (delete . ?D))) | |
675 | ||
a54a237b AK |
676 | (let ((map guix-output-list-mode-map)) |
677 | (define-key map (kbd "RET") 'guix-output-list-describe) | |
6248e326 | 678 | (define-key map (kbd "e") 'guix-list-edit-package) |
a54a237b AK |
679 | (define-key map (kbd "x") 'guix-output-list-execute) |
680 | (define-key map (kbd "i") 'guix-output-list-mark-install) | |
681 | (define-key map (kbd "d") 'guix-output-list-mark-delete) | |
682 | (define-key map (kbd "U") 'guix-output-list-mark-upgrade) | |
683 | (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) | |
684 | ||
685 | (defun guix-output-list-mark-install () | |
686 | "Mark the current output for installation and move to the next line." | |
687 | (interactive) | |
688 | (guix-package-list-marking-check) | |
689 | (let* ((entry (guix-list-current-entry)) | |
51dac383 | 690 | (installed (guix-assq-value entry 'installed))) |
a54a237b AK |
691 | (if installed |
692 | (user-error "This output is already installed") | |
578b98da | 693 | (guix-list--mark 'install t)))) |
a54a237b AK |
694 | |
695 | (defun guix-output-list-mark-delete () | |
696 | "Mark the current output for deletion and move to the next line." | |
697 | (interactive) | |
698 | (guix-package-list-marking-check) | |
699 | (let* ((entry (guix-list-current-entry)) | |
51dac383 | 700 | (installed (guix-assq-value entry 'installed))) |
a54a237b | 701 | (if installed |
578b98da | 702 | (guix-list--mark 'delete t) |
a54a237b AK |
703 | (user-error "This output is not installed")))) |
704 | ||
705 | (defun guix-output-list-mark-upgrade () | |
706 | "Mark the current output for deletion and move to the next line." | |
707 | (interactive) | |
708 | (guix-package-list-marking-check) | |
709 | (let* ((entry (guix-list-current-entry)) | |
51dac383 | 710 | (installed (guix-assq-value entry 'installed))) |
a54a237b AK |
711 | (or installed |
712 | (user-error "This output is not installed")) | |
51dac383 | 713 | (when (or (guix-assq-value entry 'obsolete) |
a54a237b | 714 | (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) |
578b98da | 715 | (guix-list--mark 'upgrade t)))) |
a54a237b AK |
716 | |
717 | (defun guix-output-list-mark-upgrades () | |
718 | "Mark all obsolete package outputs for upgrading." | |
719 | (interactive) | |
720 | (guix-list-mark-package-upgrades | |
578b98da | 721 | (lambda (_) (guix-list--mark 'upgrade)))) |
a54a237b AK |
722 | |
723 | (defun guix-output-list-execute () | |
724 | "Perform actions on the marked outputs." | |
725 | (interactive) | |
726 | (guix-list-execute-package-actions #'guix-output-list-make-action)) | |
727 | ||
728 | (defun guix-output-list-make-action (action-type) | |
729 | "Return action specification for the outputs marked with ACTION-TYPE. | |
730 | Return nil, if there are no outputs marked with ACTION-TYPE. | |
731 | The specification is suitable for `guix-process-output-actions'." | |
732 | (let ((ids (guix-list-get-marked-id-list action-type))) | |
733 | (and ids (cons action-type | |
734 | (mapcar #'guix-get-package-id-and-output-by-output-id | |
735 | ids))))) | |
736 | ||
737 | (defun guix-output-list-describe (&optional arg) | |
738 | "Describe outputs or packages marked with a general mark. | |
739 | If no entries are marked, describe the current output or package. | |
740 | With prefix (if ARG is non-nil), describe entries marked with any mark. | |
3472bb20 | 741 | Also see `guix-package-info-type'." |
a54a237b | 742 | (interactive "P") |
3472bb20 | 743 | (if (eq guix-package-info-type 'output) |
a54a237b AK |
744 | (guix-list-describe arg) |
745 | (let* ((oids (or (apply #'guix-list-get-marked-id-list | |
746 | (unless arg '(general))) | |
747 | (list (guix-list-current-id)))) | |
748 | (pids (mapcar (lambda (oid) | |
749 | (car (guix-get-package-id-and-output-by-output-id | |
750 | oid))) | |
751 | oids))) | |
752 | (guix-list-describe-maybe 'package (cl-remove-duplicates pids))))) | |
753 | ||
754 | \f | |
457f60fa AK |
755 | ;;; Displaying generations |
756 | ||
757 | (guix-define-buffer-type list generation) | |
758 | ||
759 | (guix-list-define-entry-type generation | |
760 | :sort-key number | |
761 | :invert-sort t | |
762 | :marks ((delete . ?D))) | |
763 | ||
764 | (let ((map guix-generation-list-mode-map)) | |
765 | (define-key map (kbd "RET") 'guix-generation-list-show-packages) | |
d38bd08c AK |
766 | (define-key map (kbd "+") 'guix-generation-list-show-added-packages) |
767 | (define-key map (kbd "-") 'guix-generation-list-show-removed-packages) | |
768 | (define-key map (kbd "=") 'guix-generation-list-diff) | |
769 | (define-key map (kbd "D") 'guix-generation-list-diff) | |
770 | (define-key map (kbd "e") 'guix-generation-list-ediff) | |
cb6a5c71 | 771 | (define-key map (kbd "x") 'guix-generation-list-execute) |
dfeb0239 | 772 | (define-key map (kbd "i") 'guix-list-describe) |
af874238 | 773 | (define-key map (kbd "s") 'guix-generation-list-switch) |
cb6a5c71 | 774 | (define-key map (kbd "d") 'guix-generation-list-mark-delete)) |
457f60fa | 775 | |
c2379b3c AK |
776 | (defun guix-generation-list-get-current (val &optional _) |
777 | "Return string from VAL showing whether this generation is current. | |
778 | VAL is a boolean value." | |
779 | (if val "(current)" "")) | |
780 | ||
af874238 AK |
781 | (defun guix-generation-list-switch () |
782 | "Switch current profile to the generation at point." | |
783 | (interactive) | |
784 | (let* ((entry (guix-list-current-entry)) | |
51dac383 AK |
785 | (current (guix-assq-value entry 'current)) |
786 | (number (guix-assq-value entry 'number))) | |
af874238 AK |
787 | (if current |
788 | (user-error "This generation is already the current one") | |
23459fa5 | 789 | (guix-switch-to-generation guix-profile number (current-buffer))))) |
af874238 | 790 | |
457f60fa AK |
791 | (defun guix-generation-list-show-packages () |
792 | "List installed packages for the generation at point." | |
793 | (interactive) | |
23459fa5 AK |
794 | (guix-get-show-entries guix-profile 'list guix-package-list-type |
795 | 'generation (guix-list-current-id))) | |
457f60fa | 796 | |
d38bd08c AK |
797 | (defun guix-generation-list-generations-to-compare () |
798 | "Return a sorted list of 2 marked generations for comparing." | |
799 | (let ((numbers (guix-list-get-marked-id-list 'general))) | |
800 | (if (/= (length numbers) 2) | |
801 | (user-error "2 generations should be marked for comparing") | |
802 | (sort numbers #'<)))) | |
803 | ||
804 | (defun guix-generation-list-show-added-packages () | |
805 | "List package outputs added to the latest marked generation. | |
806 | If 2 generations are marked with \\[guix-list-mark], display | |
807 | outputs installed in the latest marked generation that were not | |
808 | installed in the other one." | |
809 | (interactive) | |
810 | (apply #'guix-get-show-entries | |
811 | guix-profile 'list 'output 'generation-diff | |
812 | (reverse (guix-generation-list-generations-to-compare)))) | |
813 | ||
814 | (defun guix-generation-list-show-removed-packages () | |
815 | "List package outputs removed from the latest marked generation. | |
816 | If 2 generations are marked with \\[guix-list-mark], display | |
817 | outputs not installed in the latest marked generation that were | |
818 | installed in the other one." | |
819 | (interactive) | |
820 | (apply #'guix-get-show-entries | |
821 | guix-profile 'list 'output 'generation-diff | |
822 | (guix-generation-list-generations-to-compare))) | |
823 | ||
824 | (defun guix-generation-list-compare (diff-fun gen-fun) | |
825 | "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results." | |
826 | (cl-multiple-value-bind (gen1 gen2) | |
827 | (guix-generation-list-generations-to-compare) | |
828 | (funcall diff-fun | |
829 | (funcall gen-fun gen1) | |
830 | (funcall gen-fun gen2)))) | |
831 | ||
832 | (defun guix-generation-list-ediff-manifests () | |
833 | "Run Ediff on manifests of the 2 marked generations." | |
834 | (interactive) | |
835 | (guix-generation-list-compare | |
836 | #'ediff-files | |
837 | #'guix-profile-generation-manifest-file)) | |
838 | ||
839 | (defun guix-generation-list-diff-manifests () | |
840 | "Run Diff on manifests of the 2 marked generations." | |
841 | (interactive) | |
842 | (guix-generation-list-compare | |
843 | #'guix-diff | |
844 | #'guix-profile-generation-manifest-file)) | |
845 | ||
846 | (defun guix-generation-list-ediff-packages () | |
847 | "Run Ediff on package outputs installed in the 2 marked generations." | |
848 | (interactive) | |
849 | (guix-generation-list-compare | |
850 | #'ediff-buffers | |
851 | #'guix-profile-generation-packages-buffer)) | |
852 | ||
853 | (defun guix-generation-list-diff-packages () | |
854 | "Run Diff on package outputs installed in the 2 marked generations." | |
855 | (interactive) | |
856 | (guix-generation-list-compare | |
857 | #'guix-diff | |
858 | #'guix-profile-generation-packages-buffer)) | |
859 | ||
860 | (defun guix-generation-list-ediff (arg) | |
861 | "Run Ediff on package outputs installed in the 2 marked generations. | |
862 | With ARG, run Ediff on manifests of the marked generations." | |
863 | (interactive "P") | |
864 | (if arg | |
865 | (guix-generation-list-ediff-manifests) | |
866 | (guix-generation-list-ediff-packages))) | |
867 | ||
868 | (defun guix-generation-list-diff (arg) | |
869 | "Run Diff on package outputs installed in the 2 marked generations. | |
870 | With ARG, run Diff on manifests of the marked generations." | |
871 | (interactive "P") | |
872 | (if arg | |
873 | (guix-generation-list-diff-manifests) | |
874 | (guix-generation-list-diff-packages))) | |
875 | ||
cb6a5c71 AK |
876 | (defun guix-generation-list-mark-delete (&optional arg) |
877 | "Mark the current generation for deletion and move to the next line. | |
878 | With ARG, mark all generations for deletion." | |
879 | (interactive "P") | |
880 | (if arg | |
881 | (guix-list-mark-all 'delete) | |
578b98da | 882 | (guix-list--mark 'delete t))) |
cb6a5c71 AK |
883 | |
884 | (defun guix-generation-list-execute () | |
885 | "Delete marked generations." | |
886 | (interactive) | |
887 | (let ((marked (guix-list-get-marked-id-list 'delete))) | |
888 | (or marked | |
889 | (user-error "No generations marked for deletion")) | |
23459fa5 | 890 | (guix-delete-generations guix-profile marked (current-buffer)))) |
cb6a5c71 | 891 | |
457f60fa AK |
892 | (provide 'guix-list) |
893 | ||
894 | ;;; guix-list.el ends here |