Commit | Line | Data |
---|---|---|
9b0afb0d AK |
1 | ;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- |
2 | ||
70fd33ea | 3 | ;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> |
9b0afb0d 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 magit-like popup interface for running guix | |
23 | ;; commands in Guix REPL. The entry point is "M-x guix". When it is | |
24 | ;; called the first time, "guix --help" output is parsed and | |
25 | ;; `guix-COMMAND-action' functions are generated for each available guix | |
26 | ;; COMMAND. Then a window with these commands is popped up. When a | |
27 | ;; particular COMMAND is called, "guix COMMAND --help" output is parsed, | |
28 | ;; and a user get a new popup window with available options for this | |
29 | ;; command and so on. | |
30 | ||
31 | ;; To avoid hard-coding all guix options, actions, etc., as much data is | |
32 | ;; taken from "guix ... --help" outputs as possible. But this data is | |
33 | ;; still incomplete: not all long options have short analogs, also | |
34 | ;; special readers should be used for some options (for example, to | |
35 | ;; complete package names while prompting for a package). So after | |
36 | ;; parsing --help output, the arguments are "improved". All arguments | |
37 | ;; (switches, options and actions) are `guix-command-argument' | |
38 | ;; structures. | |
39 | ||
40 | ;; Only "M-x guix" command is available after this file is loaded. The | |
41 | ;; rest commands/actions/popups are generated on the fly only when they | |
42 | ;; are needed (that's why there is a couple of `eval'-s in this file). | |
43 | ||
44 | ;; COMMANDS argument is used by many functions in this file. It means a | |
45 | ;; list of guix commands without "guix" itself, e.g.: ("build"), | |
46 | ;; ("import" "gnu"). The empty list stands for the plain "guix" without | |
47 | ;; subcommands. | |
48 | ||
49 | ;; All actions in popup windows are divided into 2 groups: | |
50 | ;; | |
51 | ;; - 'Popup' actions - used to pop up another window. For example, every | |
52 | ;; action in the 'guix' or 'guix import' window is a popup action. They | |
53 | ;; are defined by `guix-command-define-popup-action' macro. | |
54 | ;; | |
55 | ;; - 'Execute' actions - used to do something with the command line (to | |
56 | ;; run a command in Guix REPL or to copy it into kill-ring) constructed | |
57 | ;; with the current popup. They are defined by | |
58 | ;; `guix-command-define-execute-action' macro. | |
59 | ||
60 | ;;; Code: | |
61 | ||
62 | (require 'cl-lib) | |
63 | (require 'guix-popup) | |
64 | (require 'guix-utils) | |
65 | (require 'guix-help-vars) | |
66 | (require 'guix-read) | |
67 | (require 'guix-base) | |
dcb00c0a | 68 | (require 'guix-build-log) |
c74cd6cc | 69 | (require 'guix-guile) |
761d6fd9 | 70 | (require 'guix-external) |
9b0afb0d AK |
71 | |
72 | (defgroup guix-commands nil | |
73 | "Settings for guix popup windows." | |
74 | :group 'guix) | |
75 | ||
76 | (defvar guix-command-complex-with-shared-arguments | |
77 | '("system") | |
78 | "List of guix commands which have subcommands with shared options. | |
79 | I.e., 'guix foo --help' is the same as 'guix foo bar --help'.") | |
80 | ||
81 | (defun guix-command-action-name (&optional commands &rest name-parts) | |
82 | "Return name of action function for guix COMMANDS." | |
83 | (guix-command-symbol (append commands name-parts (list "action")))) | |
84 | ||
85 | \f | |
86 | ;;; Command arguments | |
87 | ||
88 | (cl-defstruct (guix-command-argument | |
89 | (:constructor guix-command-make-argument) | |
90 | (:copier guix-command-copy-argument)) | |
91 | name char doc fun switch? option? action?) | |
92 | ||
93 | (cl-defun guix-command-modify-argument | |
94 | (argument &key | |
95 | (name nil name-bound?) | |
96 | (char nil char-bound?) | |
97 | (doc nil doc-bound?) | |
98 | (fun nil fun-bound?) | |
99 | (switch? nil switch?-bound?) | |
100 | (option? nil option?-bound?) | |
101 | (action? nil action?-bound?)) | |
102 | "Return a modified version of ARGUMENT." | |
103 | (declare (indent 1)) | |
104 | (let ((copy (guix-command-copy-argument argument))) | |
105 | (and name-bound? (setf (guix-command-argument-name copy) name)) | |
106 | (and char-bound? (setf (guix-command-argument-char copy) char)) | |
107 | (and doc-bound? (setf (guix-command-argument-doc copy) doc)) | |
108 | (and fun-bound? (setf (guix-command-argument-fun copy) fun)) | |
109 | (and switch?-bound? (setf (guix-command-argument-switch? copy) switch?)) | |
110 | (and option?-bound? (setf (guix-command-argument-option? copy) option?)) | |
111 | (and action?-bound? (setf (guix-command-argument-action? copy) action?)) | |
112 | copy)) | |
113 | ||
114 | (defun guix-command-modify-argument-from-alist (argument alist) | |
115 | "Return a modified version of ARGUMENT or nil if it wasn't modified. | |
116 | Each assoc from ALIST have a form (NAME . PLIST). NAME is an | |
117 | argument name. PLIST is a property list of argument parameters | |
118 | to be modified." | |
119 | (let* ((name (guix-command-argument-name argument)) | |
120 | (plist (guix-assoc-value alist name))) | |
121 | (when plist | |
122 | (apply #'guix-command-modify-argument | |
123 | argument plist)))) | |
124 | ||
125 | (defmacro guix-command-define-argument-improver (name alist) | |
126 | "Define NAME variable and function to modify an argument from ALIST." | |
127 | (declare (indent 1)) | |
128 | `(progn | |
129 | (defvar ,name ,alist) | |
130 | (defun ,name (argument) | |
131 | (guix-command-modify-argument-from-alist argument ,name)))) | |
132 | ||
133 | (guix-command-define-argument-improver | |
134 | guix-command-improve-action-argument | |
cfa548b4 AK |
135 | '(("container" :char ?C) |
136 | ("graph" :char ?G) | |
9b0afb0d AK |
137 | ("environment" :char ?E) |
138 | ("publish" :char ?u) | |
139 | ("pull" :char ?P) | |
140 | ("size" :char ?z))) | |
141 | ||
142 | (guix-command-define-argument-improver | |
143 | guix-command-improve-common-argument | |
144 | '(("--help" :switch? nil) | |
145 | ("--version" :switch? nil))) | |
146 | ||
147 | (guix-command-define-argument-improver | |
148 | guix-command-improve-target-argument | |
149 | '(("--target" :char ?T))) | |
150 | ||
151 | (guix-command-define-argument-improver | |
152 | guix-command-improve-system-type-argument | |
153 | '(("--system" :fun guix-read-system-type))) | |
154 | ||
155 | (guix-command-define-argument-improver | |
156 | guix-command-improve-load-path-argument | |
157 | '(("--load-path" :fun read-directory-name))) | |
158 | ||
159 | (guix-command-define-argument-improver | |
160 | guix-command-improve-search-paths-argument | |
161 | '(("--search-paths" :char ?P))) | |
162 | ||
163 | (guix-command-define-argument-improver | |
164 | guix-command-improve-substitute-urls-argument | |
165 | '(("--substitute-urls" :char ?U))) | |
166 | ||
167 | (guix-command-define-argument-improver | |
168 | guix-command-improve-hash-argument | |
169 | '(("--format" :fun guix-read-hash-format))) | |
170 | ||
171 | (guix-command-define-argument-improver | |
172 | guix-command-improve-key-policy-argument | |
173 | '(("--key-download" :fun guix-read-key-policy))) | |
174 | ||
175 | (defvar guix-command-improve-common-build-argument | |
176 | '(("--no-substitutes" :char ?s) | |
177 | ("--no-build-hook" :char ?h) | |
1ae15c36 | 178 | ("--max-silent-time" :char ?x) |
70fd33ea AK |
179 | ("--rounds" :char ?R :fun read-number) |
180 | ("--with-input" :char ?W))) | |
9b0afb0d AK |
181 | |
182 | (defun guix-command-improve-common-build-argument (argument) | |
183 | (guix-command-modify-argument-from-alist | |
184 | argument | |
185 | (append guix-command-improve-load-path-argument | |
186 | guix-command-improve-substitute-urls-argument | |
187 | guix-command-improve-common-build-argument))) | |
188 | ||
189 | (guix-command-define-argument-improver | |
190 | guix-command-improve-archive-argument | |
191 | '(("--generate-key" :char ?k))) | |
192 | ||
193 | (guix-command-define-argument-improver | |
194 | guix-command-improve-build-argument | |
195 | '(("--no-grafts" :char ?g) | |
08207339 | 196 | ("--file" :fun guix-read-file-name) |
9b0afb0d AK |
197 | ("--root" :fun guix-read-file-name) |
198 | ("--sources" :char ?S :fun guix-read-source-type :switch? nil) | |
199 | ("--with-source" :fun guix-read-file-name))) | |
200 | ||
201 | (guix-command-define-argument-improver | |
202 | guix-command-improve-environment-argument | |
8b341eb0 AK |
203 | '(("--ad-hoc" |
204 | :name "--ad-hoc " :fun guix-read-package-names-string | |
205 | :switch? nil :option? t) | |
206 | ("--expose" :char ?E) | |
207 | ("--share" :char ?S) | |
9b0afb0d AK |
208 | ("--load" :fun guix-read-file-name))) |
209 | ||
210 | (guix-command-define-argument-improver | |
211 | guix-command-improve-gc-argument | |
212 | '(("--list-dead" :char ?D) | |
213 | ("--list-live" :char ?L) | |
214 | ("--referrers" :char ?f) | |
215 | ("--verify" :fun guix-read-verify-options-string))) | |
216 | ||
217 | (guix-command-define-argument-improver | |
218 | guix-command-improve-graph-argument | |
219 | '(("--type" :fun guix-read-graph-type))) | |
220 | ||
d1f80aa4 AK |
221 | (guix-command-define-argument-improver |
222 | guix-command-improve-import-argument | |
223 | '(("cran" :char ?r))) | |
224 | ||
9b0afb0d AK |
225 | (guix-command-define-argument-improver |
226 | guix-command-improve-import-elpa-argument | |
227 | '(("--archive" :fun guix-read-elpa-archive))) | |
228 | ||
229 | (guix-command-define-argument-improver | |
230 | guix-command-improve-lint-argument | |
231 | '(("--checkers" :fun guix-read-lint-checker-names-string))) | |
232 | ||
233 | (guix-command-define-argument-improver | |
234 | guix-command-improve-package-argument | |
235 | ;; Unlike all other options, --install/--remove do not have a form | |
236 | ;; '--install=foo,bar' but '--install foo bar' instead, so we need | |
237 | ;; some tweaks. | |
238 | '(("--install" | |
239 | :name "--install " :fun guix-read-package-names-string | |
240 | :switch? nil :option? t) | |
241 | ("--remove" | |
242 | :name "--remove " :fun guix-read-package-names-string | |
243 | :switch? nil :option? t) | |
244 | ("--install-from-file" :fun guix-read-file-name) | |
245 | ("--manifest" :fun guix-read-file-name) | |
9ff17565 | 246 | ("--profile" :fun guix-read-file-name) |
9b0afb0d AK |
247 | ("--do-not-upgrade" :char ?U) |
248 | ("--roll-back" :char ?R) | |
249 | ("--show" :char ?w :fun guix-read-package-name))) | |
250 | ||
251 | (guix-command-define-argument-improver | |
252 | guix-command-improve-refresh-argument | |
253 | '(("--select" :fun guix-read-refresh-subset) | |
6407ce8e | 254 | ("--type" :fun guix-read-refresh-updater-names-string) |
9b0afb0d AK |
255 | ("--key-server" :char ?S))) |
256 | ||
257 | (guix-command-define-argument-improver | |
258 | guix-command-improve-size-argument | |
259 | '(("--map-file" :fun guix-read-file-name))) | |
260 | ||
261 | (guix-command-define-argument-improver | |
262 | guix-command-improve-system-argument | |
e0c5309a AK |
263 | '(("disk-image" :char ?D) |
264 | ("vm-image" :char ?V) | |
9b0afb0d AK |
265 | ("--on-error" :char ?E) |
266 | ("--no-grub" :char ?g) | |
267 | ("--full-boot" :char ?b))) | |
268 | ||
269 | (defvar guix-command-argument-improvers | |
270 | '((() | |
271 | guix-command-improve-action-argument) | |
272 | (("archive") | |
273 | guix-command-improve-common-build-argument | |
274 | guix-command-improve-target-argument | |
275 | guix-command-improve-system-type-argument | |
276 | guix-command-improve-archive-argument) | |
277 | (("build") | |
278 | guix-command-improve-common-build-argument | |
279 | guix-command-improve-target-argument | |
280 | guix-command-improve-system-type-argument | |
281 | guix-command-improve-build-argument) | |
282 | (("download") | |
283 | guix-command-improve-hash-argument) | |
284 | (("hash") | |
285 | guix-command-improve-hash-argument) | |
286 | (("environment") | |
287 | guix-command-improve-common-build-argument | |
288 | guix-command-improve-search-paths-argument | |
289 | guix-command-improve-system-type-argument | |
290 | guix-command-improve-environment-argument) | |
291 | (("gc") | |
292 | guix-command-improve-gc-argument) | |
293 | (("graph") | |
294 | guix-command-improve-graph-argument) | |
d1f80aa4 AK |
295 | (("import") |
296 | guix-command-improve-import-argument) | |
9b0afb0d AK |
297 | (("import" "gnu") |
298 | guix-command-improve-key-policy-argument) | |
299 | (("import" "elpa") | |
300 | guix-command-improve-import-elpa-argument) | |
301 | (("lint") | |
302 | guix-command-improve-lint-argument) | |
303 | (("package") | |
304 | guix-command-improve-common-build-argument | |
305 | guix-command-improve-search-paths-argument | |
306 | guix-command-improve-package-argument) | |
307 | (("refresh") | |
308 | guix-command-improve-key-policy-argument | |
309 | guix-command-improve-refresh-argument) | |
310 | (("size") | |
311 | guix-command-improve-system-type-argument | |
312 | guix-command-improve-substitute-urls-argument | |
313 | guix-command-improve-size-argument) | |
314 | (("system") | |
315 | guix-command-improve-common-build-argument | |
316 | guix-command-improve-system-argument)) | |
317 | "Alist of guix commands and argument improvers for them.") | |
318 | ||
319 | (defun guix-command-improve-argument (argument improvers) | |
320 | "Return ARGUMENT modified with IMPROVERS." | |
b2cb869c AK |
321 | (or (cl-some (lambda (improver) |
322 | (funcall improver argument)) | |
323 | improvers) | |
9b0afb0d AK |
324 | argument)) |
325 | ||
326 | (defun guix-command-improve-arguments (arguments commands) | |
327 | "Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface." | |
328 | (let ((improvers (cons 'guix-command-improve-common-argument | |
329 | (guix-assoc-value guix-command-argument-improvers | |
330 | commands)))) | |
331 | (mapcar (lambda (argument) | |
332 | (guix-command-improve-argument argument improvers)) | |
333 | arguments))) | |
334 | ||
335 | (defun guix-command-parse-arguments (&optional commands) | |
336 | "Return a list of parsed 'guix COMMANDS ...' arguments." | |
337 | (with-temp-buffer | |
338 | (insert (guix-help-string commands)) | |
339 | (let (args) | |
340 | (guix-while-search guix-help-parse-option-regexp | |
341 | (let* ((short (match-string-no-properties 1)) | |
342 | (name (match-string-no-properties 2)) | |
343 | (arg (match-string-no-properties 3)) | |
344 | (doc (match-string-no-properties 4)) | |
345 | (char (if short | |
346 | (elt short 1) ; short option letter | |
347 | (elt name 2))) ; first letter of the long option | |
348 | ;; If "--foo=bar" or "--foo[=bar]" then it is 'option'. | |
349 | (option? (not (string= "" arg))) | |
350 | ;; If "--foo" or "--foo[=bar]" then it is 'switch'. | |
351 | (switch? (or (string= "" arg) | |
352 | (eq ?\[ (elt arg 0))))) | |
353 | (push (guix-command-make-argument | |
354 | :name name | |
355 | :char char | |
356 | :doc doc | |
357 | :switch? switch? | |
358 | :option? option?) | |
359 | args))) | |
360 | (guix-while-search guix-help-parse-command-regexp | |
361 | (let* ((name (match-string-no-properties 1)) | |
362 | (char (elt name 0))) | |
363 | (push (guix-command-make-argument | |
364 | :name name | |
365 | :char char | |
366 | :fun (guix-command-action-name commands name) | |
367 | :action? t) | |
368 | args))) | |
369 | args))) | |
370 | ||
371 | (defun guix-command-rest-argument (&optional commands) | |
372 | "Return '--' argument for COMMANDS." | |
373 | (cl-flet ((argument (&rest args) | |
374 | (apply #'guix-command-make-argument | |
375 | :name "-- " :char ?= :option? t args))) | |
376 | (let ((command (car commands))) | |
377 | (cond | |
e1d33186 | 378 | ((member command |
8b341eb0 | 379 | '("archive" "build" "challenge" "edit" |
e1d33186 | 380 | "graph" "lint" "refresh")) |
9b0afb0d | 381 | (argument :doc "Packages" :fun 'guix-read-package-names-string)) |
cfa548b4 AK |
382 | ((equal commands '("container" "exec")) |
383 | (argument :doc "PID Command [Args...]")) | |
9b0afb0d AK |
384 | ((string= command "download") |
385 | (argument :doc "URL")) | |
8b341eb0 AK |
386 | ((string= command "environment") |
387 | (argument :doc "Command [Args...]" :fun 'read-shell-command)) | |
9b0afb0d AK |
388 | ((string= command "gc") |
389 | (argument :doc "Paths" :fun 'guix-read-file-name)) | |
390 | ((member command '("hash" "system")) | |
391 | (argument :doc "File" :fun 'guix-read-file-name)) | |
392 | ((string= command "size") | |
393 | (argument :doc "Package" :fun 'guix-read-package-name)) | |
394 | ((equal commands '("import" "nix")) | |
395 | (argument :doc "Nixpkgs Attribute")) | |
396 | ;; Other 'guix import' subcommands, but not 'import' itself. | |
397 | ((and (cdr commands) | |
398 | (string= command "import")) | |
399 | (argument :doc "Package name")))))) | |
400 | ||
8b341eb0 AK |
401 | (defvar guix-command-additional-arguments |
402 | `((("environment") | |
403 | ,(guix-command-make-argument | |
404 | :name "++packages " :char ?p :option? t | |
405 | :doc "build inputs of the specified packages" | |
406 | :fun 'guix-read-package-names-string))) | |
407 | "Alist of guix commands and additional arguments for them. | |
408 | These are 'fake' arguments that are not presented in 'guix' shell | |
409 | commands.") | |
410 | ||
9b0afb0d AK |
411 | (defun guix-command-additional-arguments (&optional commands) |
412 | "Return additional arguments for COMMANDS." | |
413 | (let ((rest-arg (guix-command-rest-argument commands))) | |
8b341eb0 AK |
414 | (append (guix-assoc-value guix-command-additional-arguments |
415 | commands) | |
416 | (and rest-arg (list rest-arg))))) | |
9b0afb0d AK |
417 | |
418 | ;; Ideally only `guix-command-arguments' function should exist with the | |
419 | ;; contents of `guix-command-all-arguments', but we need to make a | |
420 | ;; special case for `guix-command-complex-with-shared-arguments' commands. | |
421 | ||
422 | (defun guix-command-all-arguments (&optional commands) | |
423 | "Return list of all arguments for 'guix COMMANDS ...'." | |
424 | (let ((parsed (guix-command-parse-arguments commands))) | |
425 | (append (guix-command-improve-arguments parsed commands) | |
426 | (guix-command-additional-arguments commands)))) | |
427 | ||
428 | (guix-memoized-defalias guix-command-all-arguments-memoize | |
429 | guix-command-all-arguments) | |
430 | ||
431 | (defun guix-command-arguments (&optional commands) | |
432 | "Return list of arguments for 'guix COMMANDS ...'." | |
433 | (let ((command (car commands))) | |
434 | (if (member command | |
435 | guix-command-complex-with-shared-arguments) | |
436 | ;; Take actions only for 'guix system', and switches+options for | |
437 | ;; 'guix system foo'. | |
438 | (funcall (if (null (cdr commands)) | |
439 | #'cl-remove-if-not | |
440 | #'cl-remove-if) | |
441 | #'guix-command-argument-action? | |
442 | (guix-command-all-arguments-memoize (list command))) | |
443 | (guix-command-all-arguments commands)))) | |
444 | ||
445 | (defun guix-command-switch->popup-switch (switch) | |
446 | "Return popup switch from command SWITCH argument." | |
447 | (list (guix-command-argument-char switch) | |
448 | (or (guix-command-argument-doc switch) | |
449 | "Unknown") | |
450 | (guix-command-argument-name switch))) | |
451 | ||
452 | (defun guix-command-option->popup-option (option) | |
453 | "Return popup option from command OPTION argument." | |
454 | (list (guix-command-argument-char option) | |
455 | (or (guix-command-argument-doc option) | |
456 | "Unknown") | |
457 | (let ((name (guix-command-argument-name option))) | |
458 | (if (string-match-p " \\'" name) ; ends with space | |
459 | name | |
460 | (concat name "="))) | |
461 | (or (guix-command-argument-fun option) | |
462 | 'read-from-minibuffer))) | |
463 | ||
464 | (defun guix-command-action->popup-action (action) | |
465 | "Return popup action from command ACTION argument." | |
466 | (list (guix-command-argument-char action) | |
467 | (or (guix-command-argument-doc action) | |
468 | (guix-command-argument-name action) | |
469 | "Unknown") | |
470 | (guix-command-argument-fun action))) | |
471 | ||
472 | (defun guix-command-sort-arguments (arguments) | |
473 | "Sort ARGUMENTS by name in alphabetical order." | |
474 | (sort arguments | |
475 | (lambda (a1 a2) | |
476 | (let ((name1 (guix-command-argument-name a1)) | |
477 | (name2 (guix-command-argument-name a2))) | |
478 | (cond ((null name1) nil) | |
479 | ((null name2) t) | |
480 | (t (string< name1 name2))))))) | |
481 | ||
482 | (defun guix-command-switches (arguments) | |
483 | "Return switches from ARGUMENTS." | |
484 | (cl-remove-if-not #'guix-command-argument-switch? arguments)) | |
485 | ||
486 | (defun guix-command-options (arguments) | |
487 | "Return options from ARGUMENTS." | |
488 | (cl-remove-if-not #'guix-command-argument-option? arguments)) | |
489 | ||
490 | (defun guix-command-actions (arguments) | |
491 | "Return actions from ARGUMENTS." | |
492 | (cl-remove-if-not #'guix-command-argument-action? arguments)) | |
493 | ||
959c78f6 AK |
494 | \f |
495 | ;;; Post processing popup arguments | |
496 | ||
497 | (defvar guix-command-post-processors | |
8b341eb0 AK |
498 | '(("environment" |
499 | guix-command-post-process-environment-packages | |
500 | guix-command-post-process-environment-ad-hoc | |
501 | guix-command-post-process-rest-multiple-leave) | |
502 | ("hash" | |
959c78f6 AK |
503 | guix-command-post-process-rest-single) |
504 | ("package" | |
505 | guix-command-post-process-package-args) | |
506 | ("system" | |
507 | guix-command-post-process-rest-single)) | |
508 | "Alist of guix commands and functions for post-processing | |
509 | a list of arguments returned from popup interface. | |
510 | Each function is called on the returned arguments in turn.") | |
511 | ||
512 | (defvar guix-command-rest-arg-regexp | |
513 | (rx string-start "-- " (group (+ any))) | |
514 | "Regexp to match a string with the 'rest' arguments.") | |
515 | ||
516 | (defun guix-command-replace-args (args predicate modifier) | |
517 | "Replace arguments matching PREDICATE from ARGS. | |
518 | Call MODIFIER on each argument matching PREDICATE and append the | |
519 | returned list of strings to the end of ARGS. Remove the original | |
520 | arguments." | |
521 | (let* ((rest nil) | |
9b0afb0d | 522 | (args (mapcar (lambda (arg) |
959c78f6 AK |
523 | (if (funcall predicate arg) |
524 | (progn | |
525 | (push (funcall modifier arg) rest) | |
526 | nil) | |
9b0afb0d AK |
527 | arg)) |
528 | args))) | |
529 | (if rest | |
530 | (apply #'append (delq nil args) rest) | |
531 | args))) | |
532 | ||
959c78f6 AK |
533 | (cl-defun guix-command-post-process-matching-args (args regexp |
534 | &key group split?) | |
535 | "Modify arguments from ARGS matching REGEXP by moving them to | |
536 | the end of ARGS list. If SPLIT? is non-nil, split matching | |
537 | arguments into multiple subarguments." | |
538 | (guix-command-replace-args | |
539 | args | |
540 | (lambda (arg) | |
541 | (string-match regexp arg)) | |
542 | (lambda (arg) | |
543 | (let ((val (match-string (or group 0) arg)) | |
544 | (fun (if split? #'split-string #'list))) | |
545 | (funcall fun val))))) | |
546 | ||
547 | (defun guix-command-post-process-rest-single (args) | |
548 | "Modify ARGS by moving '-- ARG' argument to the end of ARGS list." | |
549 | (guix-command-post-process-matching-args | |
550 | args guix-command-rest-arg-regexp | |
551 | :group 1)) | |
552 | ||
553 | (defun guix-command-post-process-rest-multiple (args) | |
554 | "Modify ARGS by splitting '-- ARG ...' into multiple subarguments | |
555 | and moving them to the end of ARGS list. | |
556 | Remove '-- ' string." | |
557 | (guix-command-post-process-matching-args | |
558 | args guix-command-rest-arg-regexp | |
559 | :group 1 | |
560 | :split? t)) | |
561 | ||
562 | (defun guix-command-post-process-rest-multiple-leave (args) | |
563 | "Modify ARGS by splitting '-- ARG ...' into multiple subarguments | |
564 | and moving them to the end of ARGS list. | |
565 | Leave '--' string as a separate argument." | |
566 | (guix-command-post-process-matching-args | |
567 | args guix-command-rest-arg-regexp | |
568 | :split? t)) | |
569 | ||
570 | (defun guix-command-post-process-package-args (args) | |
571 | "Adjust popup ARGS for 'guix package' command." | |
572 | (guix-command-post-process-matching-args | |
573 | args (rx string-start (or "--install " "--remove ") (+ any)) | |
574 | :split? t)) | |
575 | ||
8b341eb0 AK |
576 | (defun guix-command-post-process-environment-packages (args) |
577 | "Adjust popup ARGS for specified packages of 'guix environment' | |
578 | command." | |
579 | (guix-command-post-process-matching-args | |
580 | args (rx string-start "++packages " (group (+ any))) | |
581 | :group 1 | |
582 | :split? t)) | |
583 | ||
584 | (defun guix-command-post-process-environment-ad-hoc (args) | |
585 | "Adjust popup ARGS for '--ad-hoc' argument of 'guix environment' | |
586 | command." | |
587 | (guix-command-post-process-matching-args | |
588 | args (rx string-start "--ad-hoc " (+ any)) | |
589 | :split? t)) | |
590 | ||
959c78f6 AK |
591 | (defun guix-command-post-process-args (commands args) |
592 | "Adjust popup ARGS for guix COMMANDS." | |
593 | (let* ((command (car commands)) | |
594 | (processors | |
595 | (append (guix-assoc-value guix-command-post-processors commands) | |
596 | (guix-assoc-value guix-command-post-processors command)))) | |
597 | (guix-modify args | |
598 | (or processors | |
599 | (list #'guix-command-post-process-rest-multiple))))) | |
600 | ||
9b0afb0d AK |
601 | \f |
602 | ;;; 'Execute' actions | |
603 | ||
604 | (defvar guix-command-default-execute-arguments | |
605 | (list | |
606 | (guix-command-make-argument | |
607 | :name "repl" :char ?r :doc "Run in Guix REPL") | |
608 | (guix-command-make-argument | |
609 | :name "shell" :char ?s :doc "Run in shell") | |
610 | (guix-command-make-argument | |
611 | :name "copy" :char ?c :doc "Copy command line")) | |
612 | "List of default 'execute' action arguments.") | |
613 | ||
614 | (defvar guix-command-additional-execute-arguments | |
72749575 AK |
615 | (let ((graph-arg (guix-command-make-argument |
616 | :name "view" :char ?v :doc "View graph"))) | |
617 | `((("build") | |
618 | ,(guix-command-make-argument | |
619 | :name "log" :char ?l :doc "View build log")) | |
620 | (("graph") ,graph-arg) | |
621 | (("size") | |
622 | ,(guix-command-make-argument | |
623 | :name "view" :char ?v :doc "View map")) | |
710fa231 | 624 | (("system" "shepherd-graph") ,graph-arg) |
72749575 | 625 | (("system" "extension-graph") ,graph-arg))) |
9b0afb0d AK |
626 | "Alist of guix commands and additional 'execute' action arguments.") |
627 | ||
628 | (defun guix-command-execute-arguments (commands) | |
629 | "Return a list of 'execute' action arguments for COMMANDS." | |
630 | (mapcar (lambda (arg) | |
631 | (guix-command-modify-argument arg | |
632 | :action? t | |
633 | :fun (guix-command-action-name | |
634 | commands (guix-command-argument-name arg)))) | |
635 | (append guix-command-default-execute-arguments | |
636 | (guix-assoc-value | |
637 | guix-command-additional-execute-arguments commands)))) | |
638 | ||
639 | (defvar guix-command-special-executors | |
640 | '((("environment") | |
641 | ("repl" . guix-run-environment-command-in-repl)) | |
642 | (("pull") | |
761d6fd9 | 643 | ("repl" . guix-run-pull-command-in-repl)) |
83d95c7b AK |
644 | (("build") |
645 | ("log" . guix-run-view-build-log)) | |
761d6fd9 | 646 | (("graph") |
6f05a24d AK |
647 | ("view" . guix-run-view-graph)) |
648 | (("size") | |
72749575 | 649 | ("view" . guix-run-view-size-map)) |
710fa231 | 650 | (("system" "shepherd-graph") |
72749575 AK |
651 | ("view" . guix-run-view-graph)) |
652 | (("system" "extension-graph") | |
653 | ("view" . guix-run-view-graph))) | |
9b0afb0d AK |
654 | "Alist of guix commands and alists of special executers for them. |
655 | See also `guix-command-default-executors'.") | |
656 | ||
657 | (defvar guix-command-default-executors | |
658 | '(("repl" . guix-run-command-in-repl) | |
659 | ("shell" . guix-run-command-in-shell) | |
660 | ("copy" . guix-copy-command-as-kill)) | |
661 | "Alist of default executers for action names.") | |
662 | ||
663 | (defun guix-command-executor (commands name) | |
664 | "Return function to run command line arguments for guix COMMANDS." | |
665 | (or (guix-assoc-value guix-command-special-executors commands name) | |
666 | (guix-assoc-value guix-command-default-executors name))) | |
667 | ||
668 | (defun guix-run-environment-command-in-repl (args) | |
669 | "Run 'guix ARGS ...' environment command in Guix REPL." | |
670 | ;; As 'guix environment' usually tries to run another process, it may | |
671 | ;; be fun but not wise to run this command in Geiser REPL. | |
672 | (when (or (member "--dry-run" args) | |
673 | (member "--search-paths" args) | |
674 | (when (y-or-n-p | |
675 | (format "'%s' command will spawn an external process. | |
676 | Do you really want to execute this command in Geiser REPL? " | |
677 | (guix-command-string args))) | |
678 | (message "May \"M-x shell-mode\" be with you!") | |
679 | t)) | |
680 | (guix-run-command-in-repl args))) | |
681 | ||
682 | (defun guix-run-pull-command-in-repl (args) | |
683 | "Run 'guix ARGS ...' pull command in Guix REPL. | |
684 | Perform pull-specific actions after operation, see | |
685 | `guix-after-pull-hook' and `guix-update-after-pull'." | |
686 | (guix-eval-in-repl | |
687 | (apply #'guix-make-guile-expression 'guix-command args) | |
688 | nil 'pull)) | |
689 | ||
83d95c7b AK |
690 | (defun guix-run-view-build-log (args) |
691 | "Add --log-file to ARGS, run 'guix ARGS ...' build command, and | |
692 | open the log file(s)." | |
693 | (let* ((args (if (member "--log-file" args) | |
694 | args | |
778437ed | 695 | (cl-list* (car args) "--log-file" (cdr args)))) |
83d95c7b AK |
696 | (output (guix-command-output args)) |
697 | (files (split-string output "\n" t))) | |
698 | (dolist (file files) | |
dcb00c0a | 699 | (guix-build-log-find-file file)))) |
83d95c7b | 700 | |
761d6fd9 AK |
701 | (defun guix-run-view-graph (args) |
702 | "Run 'guix ARGS ...' graph command, make the image and open it." | |
703 | (let* ((graph-file (guix-dot-file-name)) | |
704 | (dot-args (guix-dot-arguments graph-file))) | |
705 | (if (guix-eval-read (guix-make-guile-expression | |
706 | 'pipe-guix-output args dot-args)) | |
707 | (guix-find-file graph-file) | |
708 | (error "Couldn't create a graph")))) | |
709 | ||
6f05a24d AK |
710 | (defun guix-run-view-size-map (args) |
711 | "Run 'guix ARGS ...' size command, and open the map file." | |
712 | (let* ((wished-map-file | |
713 | (cl-some (lambda (arg) | |
714 | (and (string-match "--map-file=\\(.+\\)" arg) | |
715 | (match-string 1 arg))) | |
716 | args)) | |
717 | (map-file (or wished-map-file (guix-png-file-name))) | |
718 | (args (if wished-map-file | |
719 | args | |
778437ed AK |
720 | (cl-list* (car args) |
721 | (concat "--map-file=" map-file) | |
722 | (cdr args))))) | |
6f05a24d AK |
723 | (guix-command-output args) |
724 | (guix-find-file map-file))) | |
725 | ||
9b0afb0d AK |
726 | \f |
727 | ;;; Generating popups, actions, etc. | |
728 | ||
729 | (defmacro guix-command-define-popup-action (name &optional commands) | |
730 | "Define NAME function to generate (if needed) and run popup for COMMANDS." | |
731 | (declare (indent 1) (debug t)) | |
732 | (let* ((popup-fun (guix-command-symbol `(,@commands "popup"))) | |
733 | (doc (format "Call `%s' (generate it if needed)." | |
734 | popup-fun))) | |
735 | `(defun ,name (&optional arg) | |
736 | ,doc | |
737 | (interactive "P") | |
738 | (unless (fboundp ',popup-fun) | |
739 | (guix-command-generate-popup ',popup-fun ',commands)) | |
740 | (,popup-fun arg)))) | |
741 | ||
742 | (defmacro guix-command-define-execute-action (name executor | |
743 | &optional commands) | |
744 | "Define NAME function to execute the current action for guix COMMANDS. | |
745 | EXECUTOR function is called with the current command line arguments." | |
746 | (declare (indent 1) (debug t)) | |
747 | (let* ((arguments-fun (guix-command-symbol `(,@commands "arguments"))) | |
748 | (doc (format "Call `%s' with the current popup arguments." | |
749 | executor))) | |
750 | `(defun ,name (&rest args) | |
751 | ,doc | |
752 | (interactive (,arguments-fun)) | |
753 | (,executor (append ',commands | |
959c78f6 AK |
754 | (guix-command-post-process-args |
755 | ',commands args)))))) | |
9b0afb0d AK |
756 | |
757 | (defun guix-command-generate-popup-actions (actions &optional commands) | |
758 | "Generate 'popup' commands from ACTIONS arguments for guix COMMANDS." | |
759 | (dolist (action actions) | |
760 | (let ((fun (guix-command-argument-fun action))) | |
761 | (unless (fboundp fun) | |
762 | (eval `(guix-command-define-popup-action ,fun | |
763 | ,(append commands | |
764 | (list (guix-command-argument-name action))))))))) | |
765 | ||
766 | (defun guix-command-generate-execute-actions (actions &optional commands) | |
767 | "Generate 'execute' commands from ACTIONS arguments for guix COMMANDS." | |
768 | (dolist (action actions) | |
769 | (let ((fun (guix-command-argument-fun action))) | |
770 | (unless (fboundp fun) | |
771 | (eval `(guix-command-define-execute-action ,fun | |
772 | ,(guix-command-executor | |
773 | commands (guix-command-argument-name action)) | |
774 | ,commands)))))) | |
775 | ||
776 | (defun guix-command-generate-popup (name &optional commands) | |
777 | "Define NAME popup with 'guix COMMANDS ...' interface." | |
778 | (let* ((command (car commands)) | |
779 | (man-page (concat "guix" (and command (concat "-" command)))) | |
780 | (doc (format "Popup window for '%s' command." | |
781 | (guix-concat-strings (cons "guix" commands) | |
782 | " "))) | |
783 | (args (guix-command-arguments commands)) | |
784 | (switches (guix-command-sort-arguments | |
785 | (guix-command-switches args))) | |
786 | (options (guix-command-sort-arguments | |
787 | (guix-command-options args))) | |
788 | (popup-actions (guix-command-sort-arguments | |
789 | (guix-command-actions args))) | |
790 | (execute-actions (unless popup-actions | |
791 | (guix-command-execute-arguments commands))) | |
792 | (actions (or popup-actions execute-actions))) | |
793 | (if popup-actions | |
794 | (guix-command-generate-popup-actions popup-actions commands) | |
795 | (guix-command-generate-execute-actions execute-actions commands)) | |
796 | (eval | |
797 | `(guix-define-popup ,name | |
798 | ,doc | |
799 | 'guix-commands | |
800 | :man-page ,man-page | |
801 | :switches ',(mapcar #'guix-command-switch->popup-switch switches) | |
802 | :options ',(mapcar #'guix-command-option->popup-option options) | |
803 | :actions ',(mapcar #'guix-command-action->popup-action actions) | |
804 | :max-action-columns 4)))) | |
805 | ||
806 | ;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t) | |
807 | (guix-command-define-popup-action guix) | |
808 | ||
eb097f36 AK |
809 | (defalias 'guix-edit-action #'guix-edit) |
810 | ||
9b0afb0d AK |
811 | \f |
812 | (defvar guix-command-font-lock-keywords | |
813 | (eval-when-compile | |
814 | `((,(rx "(" | |
815 | (group "guix-command-define-" | |
816 | (or "popup-action" | |
817 | "execute-action" | |
818 | "argument-improver")) | |
819 | symbol-end | |
820 | (zero-or-more blank) | |
821 | (zero-or-one | |
822 | (group (one-or-more (or (syntax word) (syntax symbol)))))) | |
823 | (1 font-lock-keyword-face) | |
824 | (2 font-lock-function-name-face nil t))))) | |
825 | ||
826 | (font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords) | |
827 | ||
828 | (provide 'guix-command) | |
829 | ||
830 | ;;; guix-command.el ends here |