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