Commit | Line | Data |
---|---|---|
9b0afb0d AK |
1 | ;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- |
2 | ||
3 | ;; Copyright © 2015 Alex Kost <alezost@gmail.com> | |
4 | ||
5 | ;; This file is part of GNU Guix. | |
6 | ||
7 | ;; GNU Guix is free software; you can redistribute it and/or modify | |
8 | ;; it under the terms of the GNU General Public License as published by | |
9 | ;; the Free Software Foundation, either version 3 of the License, or | |
10 | ;; (at your option) any later version. | |
11 | ||
12 | ;; GNU Guix is distributed in the hope that it will be useful, | |
13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;; GNU General Public License for more details. | |
16 | ||
17 | ;; You should have received a copy of the GNU General Public License | |
18 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; This file provides 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) | |
c74cd6cc | 68 | (require 'guix-guile) |
761d6fd9 | 69 | (require 'guix-external) |
9b0afb0d AK |
70 | |
71 | (defgroup guix-commands nil | |
72 | "Settings for guix popup windows." | |
73 | :group 'guix) | |
74 | ||
75 | (defvar guix-command-complex-with-shared-arguments | |
76 | '("system") | |
77 | "List of guix commands which have subcommands with shared options. | |
78 | I.e., 'guix foo --help' is the same as 'guix foo bar --help'.") | |
79 | ||
80 | (defun guix-command-action-name (&optional commands &rest name-parts) | |
81 | "Return name of action function for guix COMMANDS." | |
82 | (guix-command-symbol (append commands name-parts (list "action")))) | |
83 | ||
84 | \f | |
85 | ;;; Command arguments | |
86 | ||
87 | (cl-defstruct (guix-command-argument | |
88 | (:constructor guix-command-make-argument) | |
89 | (:copier guix-command-copy-argument)) | |
90 | name char doc fun switch? option? action?) | |
91 | ||
92 | (cl-defun guix-command-modify-argument | |
93 | (argument &key | |
94 | (name nil name-bound?) | |
95 | (char nil char-bound?) | |
96 | (doc nil doc-bound?) | |
97 | (fun nil fun-bound?) | |
98 | (switch? nil switch?-bound?) | |
99 | (option? nil option?-bound?) | |
100 | (action? nil action?-bound?)) | |
101 | "Return a modified version of ARGUMENT." | |
102 | (declare (indent 1)) | |
103 | (let ((copy (guix-command-copy-argument argument))) | |
104 | (and name-bound? (setf (guix-command-argument-name copy) name)) | |
105 | (and char-bound? (setf (guix-command-argument-char copy) char)) | |
106 | (and doc-bound? (setf (guix-command-argument-doc copy) doc)) | |
107 | (and fun-bound? (setf (guix-command-argument-fun copy) fun)) | |
108 | (and switch?-bound? (setf (guix-command-argument-switch? copy) switch?)) | |
109 | (and option?-bound? (setf (guix-command-argument-option? copy) option?)) | |
110 | (and action?-bound? (setf (guix-command-argument-action? copy) action?)) | |
111 | copy)) | |
112 | ||
113 | (defun guix-command-modify-argument-from-alist (argument alist) | |
114 | "Return a modified version of ARGUMENT or nil if it wasn't modified. | |
115 | Each assoc from ALIST have a form (NAME . PLIST). NAME is an | |
116 | argument name. PLIST is a property list of argument parameters | |
117 | to be modified." | |
118 | (let* ((name (guix-command-argument-name argument)) | |
119 | (plist (guix-assoc-value alist name))) | |
120 | (when plist | |
121 | (apply #'guix-command-modify-argument | |
122 | argument plist)))) | |
123 | ||
124 | (defmacro guix-command-define-argument-improver (name alist) | |
125 | "Define NAME variable and function to modify an argument from ALIST." | |
126 | (declare (indent 1)) | |
127 | `(progn | |
128 | (defvar ,name ,alist) | |
129 | (defun ,name (argument) | |
130 | (guix-command-modify-argument-from-alist argument ,name)))) | |
131 | ||
132 | (guix-command-define-argument-improver | |
133 | guix-command-improve-action-argument | |
134 | '(("graph" :char ?G) | |
135 | ("environment" :char ?E) | |
136 | ("publish" :char ?u) | |
137 | ("pull" :char ?P) | |
138 | ("size" :char ?z))) | |
139 | ||
140 | (guix-command-define-argument-improver | |
141 | guix-command-improve-common-argument | |
142 | '(("--help" :switch? nil) | |
143 | ("--version" :switch? nil))) | |
144 | ||
145 | (guix-command-define-argument-improver | |
146 | guix-command-improve-target-argument | |
147 | '(("--target" :char ?T))) | |
148 | ||
149 | (guix-command-define-argument-improver | |
150 | guix-command-improve-system-type-argument | |
151 | '(("--system" :fun guix-read-system-type))) | |
152 | ||
153 | (guix-command-define-argument-improver | |
154 | guix-command-improve-load-path-argument | |
155 | '(("--load-path" :fun read-directory-name))) | |
156 | ||
157 | (guix-command-define-argument-improver | |
158 | guix-command-improve-search-paths-argument | |
159 | '(("--search-paths" :char ?P))) | |
160 | ||
161 | (guix-command-define-argument-improver | |
162 | guix-command-improve-substitute-urls-argument | |
163 | '(("--substitute-urls" :char ?U))) | |
164 | ||
165 | (guix-command-define-argument-improver | |
166 | guix-command-improve-hash-argument | |
167 | '(("--format" :fun guix-read-hash-format))) | |
168 | ||
169 | (guix-command-define-argument-improver | |
170 | guix-command-improve-key-policy-argument | |
171 | '(("--key-download" :fun guix-read-key-policy))) | |
172 | ||
173 | (defvar guix-command-improve-common-build-argument | |
174 | '(("--no-substitutes" :char ?s) | |
175 | ("--no-build-hook" :char ?h) | |
176 | ("--max-silent-time" :char ?x))) | |
177 | ||
178 | (defun guix-command-improve-common-build-argument (argument) | |
179 | (guix-command-modify-argument-from-alist | |
180 | argument | |
181 | (append guix-command-improve-load-path-argument | |
182 | guix-command-improve-substitute-urls-argument | |
183 | guix-command-improve-common-build-argument))) | |
184 | ||
185 | (guix-command-define-argument-improver | |
186 | guix-command-improve-archive-argument | |
187 | '(("--generate-key" :char ?k))) | |
188 | ||
189 | (guix-command-define-argument-improver | |
190 | guix-command-improve-build-argument | |
191 | '(("--no-grafts" :char ?g) | |
192 | ("--root" :fun guix-read-file-name) | |
193 | ("--sources" :char ?S :fun guix-read-source-type :switch? nil) | |
194 | ("--with-source" :fun guix-read-file-name))) | |
195 | ||
196 | (guix-command-define-argument-improver | |
197 | guix-command-improve-environment-argument | |
198 | '(("--exec" :fun read-shell-command) | |
199 | ("--load" :fun guix-read-file-name))) | |
200 | ||
201 | (guix-command-define-argument-improver | |
202 | guix-command-improve-gc-argument | |
203 | '(("--list-dead" :char ?D) | |
204 | ("--list-live" :char ?L) | |
205 | ("--referrers" :char ?f) | |
206 | ("--verify" :fun guix-read-verify-options-string))) | |
207 | ||
208 | (guix-command-define-argument-improver | |
209 | guix-command-improve-graph-argument | |
210 | '(("--type" :fun guix-read-graph-type))) | |
211 | ||
d1f80aa4 AK |
212 | (guix-command-define-argument-improver |
213 | guix-command-improve-import-argument | |
214 | '(("cran" :char ?r))) | |
215 | ||
9b0afb0d AK |
216 | (guix-command-define-argument-improver |
217 | guix-command-improve-import-elpa-argument | |
218 | '(("--archive" :fun guix-read-elpa-archive))) | |
219 | ||
220 | (guix-command-define-argument-improver | |
221 | guix-command-improve-lint-argument | |
222 | '(("--checkers" :fun guix-read-lint-checker-names-string))) | |
223 | ||
224 | (guix-command-define-argument-improver | |
225 | guix-command-improve-package-argument | |
226 | ;; Unlike all other options, --install/--remove do not have a form | |
227 | ;; '--install=foo,bar' but '--install foo bar' instead, so we need | |
228 | ;; some tweaks. | |
229 | '(("--install" | |
230 | :name "--install " :fun guix-read-package-names-string | |
231 | :switch? nil :option? t) | |
232 | ("--remove" | |
233 | :name "--remove " :fun guix-read-package-names-string | |
234 | :switch? nil :option? t) | |
235 | ("--install-from-file" :fun guix-read-file-name) | |
236 | ("--manifest" :fun guix-read-file-name) | |
237 | ("--do-not-upgrade" :char ?U) | |
238 | ("--roll-back" :char ?R) | |
239 | ("--show" :char ?w :fun guix-read-package-name))) | |
240 | ||
241 | (guix-command-define-argument-improver | |
242 | guix-command-improve-refresh-argument | |
243 | '(("--select" :fun guix-read-refresh-subset) | |
6407ce8e | 244 | ("--type" :fun guix-read-refresh-updater-names-string) |
9b0afb0d AK |
245 | ("--key-server" :char ?S))) |
246 | ||
247 | (guix-command-define-argument-improver | |
248 | guix-command-improve-size-argument | |
249 | '(("--map-file" :fun guix-read-file-name))) | |
250 | ||
251 | (guix-command-define-argument-improver | |
252 | guix-command-improve-system-argument | |
e0c5309a AK |
253 | '(("disk-image" :char ?D) |
254 | ("vm-image" :char ?V) | |
9b0afb0d AK |
255 | ("--on-error" :char ?E) |
256 | ("--no-grub" :char ?g) | |
257 | ("--full-boot" :char ?b))) | |
258 | ||
259 | (defvar guix-command-argument-improvers | |
260 | '((() | |
261 | guix-command-improve-action-argument) | |
262 | (("archive") | |
263 | guix-command-improve-common-build-argument | |
264 | guix-command-improve-target-argument | |
265 | guix-command-improve-system-type-argument | |
266 | guix-command-improve-archive-argument) | |
267 | (("build") | |
268 | guix-command-improve-common-build-argument | |
269 | guix-command-improve-target-argument | |
270 | guix-command-improve-system-type-argument | |
271 | guix-command-improve-build-argument) | |
272 | (("download") | |
273 | guix-command-improve-hash-argument) | |
274 | (("hash") | |
275 | guix-command-improve-hash-argument) | |
276 | (("environment") | |
277 | guix-command-improve-common-build-argument | |
278 | guix-command-improve-search-paths-argument | |
279 | guix-command-improve-system-type-argument | |
280 | guix-command-improve-environment-argument) | |
281 | (("gc") | |
282 | guix-command-improve-gc-argument) | |
283 | (("graph") | |
284 | guix-command-improve-graph-argument) | |
d1f80aa4 AK |
285 | (("import") |
286 | guix-command-improve-import-argument) | |
9b0afb0d AK |
287 | (("import" "gnu") |
288 | guix-command-improve-key-policy-argument) | |
289 | (("import" "elpa") | |
290 | guix-command-improve-import-elpa-argument) | |
291 | (("lint") | |
292 | guix-command-improve-lint-argument) | |
293 | (("package") | |
294 | guix-command-improve-common-build-argument | |
295 | guix-command-improve-search-paths-argument | |
296 | guix-command-improve-package-argument) | |
297 | (("refresh") | |
298 | guix-command-improve-key-policy-argument | |
299 | guix-command-improve-refresh-argument) | |
300 | (("size") | |
301 | guix-command-improve-system-type-argument | |
302 | guix-command-improve-substitute-urls-argument | |
303 | guix-command-improve-size-argument) | |
304 | (("system") | |
305 | guix-command-improve-common-build-argument | |
306 | guix-command-improve-system-argument)) | |
307 | "Alist of guix commands and argument improvers for them.") | |
308 | ||
309 | (defun guix-command-improve-argument (argument improvers) | |
310 | "Return ARGUMENT modified with IMPROVERS." | |
b2cb869c AK |
311 | (or (cl-some (lambda (improver) |
312 | (funcall improver argument)) | |
313 | improvers) | |
9b0afb0d AK |
314 | argument)) |
315 | ||
316 | (defun guix-command-improve-arguments (arguments commands) | |
317 | "Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface." | |
318 | (let ((improvers (cons 'guix-command-improve-common-argument | |
319 | (guix-assoc-value guix-command-argument-improvers | |
320 | commands)))) | |
321 | (mapcar (lambda (argument) | |
322 | (guix-command-improve-argument argument improvers)) | |
323 | arguments))) | |
324 | ||
325 | (defun guix-command-parse-arguments (&optional commands) | |
326 | "Return a list of parsed 'guix COMMANDS ...' arguments." | |
327 | (with-temp-buffer | |
328 | (insert (guix-help-string commands)) | |
329 | (let (args) | |
330 | (guix-while-search guix-help-parse-option-regexp | |
331 | (let* ((short (match-string-no-properties 1)) | |
332 | (name (match-string-no-properties 2)) | |
333 | (arg (match-string-no-properties 3)) | |
334 | (doc (match-string-no-properties 4)) | |
335 | (char (if short | |
336 | (elt short 1) ; short option letter | |
337 | (elt name 2))) ; first letter of the long option | |
338 | ;; If "--foo=bar" or "--foo[=bar]" then it is 'option'. | |
339 | (option? (not (string= "" arg))) | |
340 | ;; If "--foo" or "--foo[=bar]" then it is 'switch'. | |
341 | (switch? (or (string= "" arg) | |
342 | (eq ?\[ (elt arg 0))))) | |
343 | (push (guix-command-make-argument | |
344 | :name name | |
345 | :char char | |
346 | :doc doc | |
347 | :switch? switch? | |
348 | :option? option?) | |
349 | args))) | |
350 | (guix-while-search guix-help-parse-command-regexp | |
351 | (let* ((name (match-string-no-properties 1)) | |
352 | (char (elt name 0))) | |
353 | (push (guix-command-make-argument | |
354 | :name name | |
355 | :char char | |
356 | :fun (guix-command-action-name commands name) | |
357 | :action? t) | |
358 | args))) | |
359 | args))) | |
360 | ||
361 | (defun guix-command-rest-argument (&optional commands) | |
362 | "Return '--' argument for COMMANDS." | |
363 | (cl-flet ((argument (&rest args) | |
364 | (apply #'guix-command-make-argument | |
365 | :name "-- " :char ?= :option? t args))) | |
366 | (let ((command (car commands))) | |
367 | (cond | |
e1d33186 AK |
368 | ((member command |
369 | '("archive" "build" "challenge" "edit" "environment" | |
370 | "graph" "lint" "refresh")) | |
9b0afb0d AK |
371 | (argument :doc "Packages" :fun 'guix-read-package-names-string)) |
372 | ((string= command "download") | |
373 | (argument :doc "URL")) | |
374 | ((string= command "gc") | |
375 | (argument :doc "Paths" :fun 'guix-read-file-name)) | |
376 | ((member command '("hash" "system")) | |
377 | (argument :doc "File" :fun 'guix-read-file-name)) | |
378 | ((string= command "size") | |
379 | (argument :doc "Package" :fun 'guix-read-package-name)) | |
380 | ((equal commands '("import" "nix")) | |
381 | (argument :doc "Nixpkgs Attribute")) | |
382 | ;; Other 'guix import' subcommands, but not 'import' itself. | |
383 | ((and (cdr commands) | |
384 | (string= command "import")) | |
385 | (argument :doc "Package name")))))) | |
386 | ||
387 | (defun guix-command-additional-arguments (&optional commands) | |
388 | "Return additional arguments for COMMANDS." | |
389 | (let ((rest-arg (guix-command-rest-argument commands))) | |
390 | (and rest-arg (list rest-arg)))) | |
391 | ||
392 | ;; Ideally only `guix-command-arguments' function should exist with the | |
393 | ;; contents of `guix-command-all-arguments', but we need to make a | |
394 | ;; special case for `guix-command-complex-with-shared-arguments' commands. | |
395 | ||
396 | (defun guix-command-all-arguments (&optional commands) | |
397 | "Return list of all arguments for 'guix COMMANDS ...'." | |
398 | (let ((parsed (guix-command-parse-arguments commands))) | |
399 | (append (guix-command-improve-arguments parsed commands) | |
400 | (guix-command-additional-arguments commands)))) | |
401 | ||
402 | (guix-memoized-defalias guix-command-all-arguments-memoize | |
403 | guix-command-all-arguments) | |
404 | ||
405 | (defun guix-command-arguments (&optional commands) | |
406 | "Return list of arguments for 'guix COMMANDS ...'." | |
407 | (let ((command (car commands))) | |
408 | (if (member command | |
409 | guix-command-complex-with-shared-arguments) | |
410 | ;; Take actions only for 'guix system', and switches+options for | |
411 | ;; 'guix system foo'. | |
412 | (funcall (if (null (cdr commands)) | |
413 | #'cl-remove-if-not | |
414 | #'cl-remove-if) | |
415 | #'guix-command-argument-action? | |
416 | (guix-command-all-arguments-memoize (list command))) | |
417 | (guix-command-all-arguments commands)))) | |
418 | ||
419 | (defun guix-command-switch->popup-switch (switch) | |
420 | "Return popup switch from command SWITCH argument." | |
421 | (list (guix-command-argument-char switch) | |
422 | (or (guix-command-argument-doc switch) | |
423 | "Unknown") | |
424 | (guix-command-argument-name switch))) | |
425 | ||
426 | (defun guix-command-option->popup-option (option) | |
427 | "Return popup option from command OPTION argument." | |
428 | (list (guix-command-argument-char option) | |
429 | (or (guix-command-argument-doc option) | |
430 | "Unknown") | |
431 | (let ((name (guix-command-argument-name option))) | |
432 | (if (string-match-p " \\'" name) ; ends with space | |
433 | name | |
434 | (concat name "="))) | |
435 | (or (guix-command-argument-fun option) | |
436 | 'read-from-minibuffer))) | |
437 | ||
438 | (defun guix-command-action->popup-action (action) | |
439 | "Return popup action from command ACTION argument." | |
440 | (list (guix-command-argument-char action) | |
441 | (or (guix-command-argument-doc action) | |
442 | (guix-command-argument-name action) | |
443 | "Unknown") | |
444 | (guix-command-argument-fun action))) | |
445 | ||
446 | (defun guix-command-sort-arguments (arguments) | |
447 | "Sort ARGUMENTS by name in alphabetical order." | |
448 | (sort arguments | |
449 | (lambda (a1 a2) | |
450 | (let ((name1 (guix-command-argument-name a1)) | |
451 | (name2 (guix-command-argument-name a2))) | |
452 | (cond ((null name1) nil) | |
453 | ((null name2) t) | |
454 | (t (string< name1 name2))))))) | |
455 | ||
456 | (defun guix-command-switches (arguments) | |
457 | "Return switches from ARGUMENTS." | |
458 | (cl-remove-if-not #'guix-command-argument-switch? arguments)) | |
459 | ||
460 | (defun guix-command-options (arguments) | |
461 | "Return options from ARGUMENTS." | |
462 | (cl-remove-if-not #'guix-command-argument-option? arguments)) | |
463 | ||
464 | (defun guix-command-actions (arguments) | |
465 | "Return actions from ARGUMENTS." | |
466 | (cl-remove-if-not #'guix-command-argument-action? arguments)) | |
467 | ||
468 | (defun guix-command-post-process-args (args) | |
469 | "Adjust appropriately command line ARGS returned from popup command." | |
470 | ;; XXX We need to split "--install foo bar" and similar strings into | |
471 | ;; lists of strings. But some commands (e.g., 'guix hash') accept a | |
472 | ;; file name as the 'rest' argument, and as file names may contain | |
473 | ;; spaces, splitting by spaces will break such names. For example, the | |
474 | ;; following argument: "-- /tmp/file with spaces" will be transformed | |
475 | ;; into the following list: ("--" "/tmp/file" "with" "spaces") instead | |
476 | ;; of the wished ("--" "/tmp/file with spaces"). | |
477 | (let* (rest | |
478 | (rx (rx string-start | |
479 | (or "-- " "--install " "--remove "))) | |
480 | (args (mapcar (lambda (arg) | |
481 | (if (string-match-p rx arg) | |
482 | (progn (push (split-string arg) rest) | |
483 | nil) | |
484 | arg)) | |
485 | args))) | |
486 | (if rest | |
487 | (apply #'append (delq nil args) rest) | |
488 | args))) | |
489 | ||
490 | \f | |
491 | ;;; 'Execute' actions | |
492 | ||
493 | (defvar guix-command-default-execute-arguments | |
494 | (list | |
495 | (guix-command-make-argument | |
496 | :name "repl" :char ?r :doc "Run in Guix REPL") | |
497 | (guix-command-make-argument | |
498 | :name "shell" :char ?s :doc "Run in shell") | |
499 | (guix-command-make-argument | |
500 | :name "copy" :char ?c :doc "Copy command line")) | |
501 | "List of default 'execute' action arguments.") | |
502 | ||
503 | (defvar guix-command-additional-execute-arguments | |
72749575 AK |
504 | (let ((graph-arg (guix-command-make-argument |
505 | :name "view" :char ?v :doc "View graph"))) | |
506 | `((("build") | |
507 | ,(guix-command-make-argument | |
508 | :name "log" :char ?l :doc "View build log")) | |
509 | (("graph") ,graph-arg) | |
510 | (("size") | |
511 | ,(guix-command-make-argument | |
512 | :name "view" :char ?v :doc "View map")) | |
513 | (("system" "dmd-graph") ,graph-arg) | |
514 | (("system" "extension-graph") ,graph-arg))) | |
9b0afb0d AK |
515 | "Alist of guix commands and additional 'execute' action arguments.") |
516 | ||
517 | (defun guix-command-execute-arguments (commands) | |
518 | "Return a list of 'execute' action arguments for COMMANDS." | |
519 | (mapcar (lambda (arg) | |
520 | (guix-command-modify-argument arg | |
521 | :action? t | |
522 | :fun (guix-command-action-name | |
523 | commands (guix-command-argument-name arg)))) | |
524 | (append guix-command-default-execute-arguments | |
525 | (guix-assoc-value | |
526 | guix-command-additional-execute-arguments commands)))) | |
527 | ||
528 | (defvar guix-command-special-executors | |
529 | '((("environment") | |
530 | ("repl" . guix-run-environment-command-in-repl)) | |
531 | (("pull") | |
761d6fd9 | 532 | ("repl" . guix-run-pull-command-in-repl)) |
83d95c7b AK |
533 | (("build") |
534 | ("log" . guix-run-view-build-log)) | |
761d6fd9 | 535 | (("graph") |
6f05a24d AK |
536 | ("view" . guix-run-view-graph)) |
537 | (("size") | |
72749575 AK |
538 | ("view" . guix-run-view-size-map)) |
539 | (("system" "dmd-graph") | |
540 | ("view" . guix-run-view-graph)) | |
541 | (("system" "extension-graph") | |
542 | ("view" . guix-run-view-graph))) | |
9b0afb0d AK |
543 | "Alist of guix commands and alists of special executers for them. |
544 | See also `guix-command-default-executors'.") | |
545 | ||
546 | (defvar guix-command-default-executors | |
547 | '(("repl" . guix-run-command-in-repl) | |
548 | ("shell" . guix-run-command-in-shell) | |
549 | ("copy" . guix-copy-command-as-kill)) | |
550 | "Alist of default executers for action names.") | |
551 | ||
552 | (defun guix-command-executor (commands name) | |
553 | "Return function to run command line arguments for guix COMMANDS." | |
554 | (or (guix-assoc-value guix-command-special-executors commands name) | |
555 | (guix-assoc-value guix-command-default-executors name))) | |
556 | ||
557 | (defun guix-run-environment-command-in-repl (args) | |
558 | "Run 'guix ARGS ...' environment command in Guix REPL." | |
559 | ;; As 'guix environment' usually tries to run another process, it may | |
560 | ;; be fun but not wise to run this command in Geiser REPL. | |
561 | (when (or (member "--dry-run" args) | |
562 | (member "--search-paths" args) | |
563 | (when (y-or-n-p | |
564 | (format "'%s' command will spawn an external process. | |
565 | Do you really want to execute this command in Geiser REPL? " | |
566 | (guix-command-string args))) | |
567 | (message "May \"M-x shell-mode\" be with you!") | |
568 | t)) | |
569 | (guix-run-command-in-repl args))) | |
570 | ||
571 | (defun guix-run-pull-command-in-repl (args) | |
572 | "Run 'guix ARGS ...' pull command in Guix REPL. | |
573 | Perform pull-specific actions after operation, see | |
574 | `guix-after-pull-hook' and `guix-update-after-pull'." | |
575 | (guix-eval-in-repl | |
576 | (apply #'guix-make-guile-expression 'guix-command args) | |
577 | nil 'pull)) | |
578 | ||
83d95c7b AK |
579 | (defun guix-run-view-build-log (args) |
580 | "Add --log-file to ARGS, run 'guix ARGS ...' build command, and | |
581 | open the log file(s)." | |
582 | (let* ((args (if (member "--log-file" args) | |
583 | args | |
584 | (apply #'list (car args) "--log-file" (cdr args)))) | |
585 | (output (guix-command-output args)) | |
586 | (files (split-string output "\n" t))) | |
587 | (dolist (file files) | |
588 | (guix-find-file-or-url file) | |
589 | (guix-build-log-mode)))) | |
590 | ||
761d6fd9 AK |
591 | (defun guix-run-view-graph (args) |
592 | "Run 'guix ARGS ...' graph command, make the image and open it." | |
593 | (let* ((graph-file (guix-dot-file-name)) | |
594 | (dot-args (guix-dot-arguments graph-file))) | |
595 | (if (guix-eval-read (guix-make-guile-expression | |
596 | 'pipe-guix-output args dot-args)) | |
597 | (guix-find-file graph-file) | |
598 | (error "Couldn't create a graph")))) | |
599 | ||
6f05a24d AK |
600 | (defun guix-run-view-size-map (args) |
601 | "Run 'guix ARGS ...' size command, and open the map file." | |
602 | (let* ((wished-map-file | |
603 | (cl-some (lambda (arg) | |
604 | (and (string-match "--map-file=\\(.+\\)" arg) | |
605 | (match-string 1 arg))) | |
606 | args)) | |
607 | (map-file (or wished-map-file (guix-png-file-name))) | |
608 | (args (if wished-map-file | |
609 | args | |
610 | (apply #'list | |
611 | (car args) | |
612 | (concat "--map-file=" map-file) | |
613 | (cdr args))))) | |
614 | (guix-command-output args) | |
615 | (guix-find-file map-file))) | |
616 | ||
9b0afb0d AK |
617 | \f |
618 | ;;; Generating popups, actions, etc. | |
619 | ||
620 | (defmacro guix-command-define-popup-action (name &optional commands) | |
621 | "Define NAME function to generate (if needed) and run popup for COMMANDS." | |
622 | (declare (indent 1) (debug t)) | |
623 | (let* ((popup-fun (guix-command-symbol `(,@commands "popup"))) | |
624 | (doc (format "Call `%s' (generate it if needed)." | |
625 | popup-fun))) | |
626 | `(defun ,name (&optional arg) | |
627 | ,doc | |
628 | (interactive "P") | |
629 | (unless (fboundp ',popup-fun) | |
630 | (guix-command-generate-popup ',popup-fun ',commands)) | |
631 | (,popup-fun arg)))) | |
632 | ||
633 | (defmacro guix-command-define-execute-action (name executor | |
634 | &optional commands) | |
635 | "Define NAME function to execute the current action for guix COMMANDS. | |
636 | EXECUTOR function is called with the current command line arguments." | |
637 | (declare (indent 1) (debug t)) | |
638 | (let* ((arguments-fun (guix-command-symbol `(,@commands "arguments"))) | |
639 | (doc (format "Call `%s' with the current popup arguments." | |
640 | executor))) | |
641 | `(defun ,name (&rest args) | |
642 | ,doc | |
643 | (interactive (,arguments-fun)) | |
644 | (,executor (append ',commands | |
645 | (guix-command-post-process-args args)))))) | |
646 | ||
647 | (defun guix-command-generate-popup-actions (actions &optional commands) | |
648 | "Generate 'popup' commands from ACTIONS arguments for guix COMMANDS." | |
649 | (dolist (action actions) | |
650 | (let ((fun (guix-command-argument-fun action))) | |
651 | (unless (fboundp fun) | |
652 | (eval `(guix-command-define-popup-action ,fun | |
653 | ,(append commands | |
654 | (list (guix-command-argument-name action))))))))) | |
655 | ||
656 | (defun guix-command-generate-execute-actions (actions &optional commands) | |
657 | "Generate 'execute' commands from ACTIONS arguments for guix COMMANDS." | |
658 | (dolist (action actions) | |
659 | (let ((fun (guix-command-argument-fun action))) | |
660 | (unless (fboundp fun) | |
661 | (eval `(guix-command-define-execute-action ,fun | |
662 | ,(guix-command-executor | |
663 | commands (guix-command-argument-name action)) | |
664 | ,commands)))))) | |
665 | ||
666 | (defun guix-command-generate-popup (name &optional commands) | |
667 | "Define NAME popup with 'guix COMMANDS ...' interface." | |
668 | (let* ((command (car commands)) | |
669 | (man-page (concat "guix" (and command (concat "-" command)))) | |
670 | (doc (format "Popup window for '%s' command." | |
671 | (guix-concat-strings (cons "guix" commands) | |
672 | " "))) | |
673 | (args (guix-command-arguments commands)) | |
674 | (switches (guix-command-sort-arguments | |
675 | (guix-command-switches args))) | |
676 | (options (guix-command-sort-arguments | |
677 | (guix-command-options args))) | |
678 | (popup-actions (guix-command-sort-arguments | |
679 | (guix-command-actions args))) | |
680 | (execute-actions (unless popup-actions | |
681 | (guix-command-execute-arguments commands))) | |
682 | (actions (or popup-actions execute-actions))) | |
683 | (if popup-actions | |
684 | (guix-command-generate-popup-actions popup-actions commands) | |
685 | (guix-command-generate-execute-actions execute-actions commands)) | |
686 | (eval | |
687 | `(guix-define-popup ,name | |
688 | ,doc | |
689 | 'guix-commands | |
690 | :man-page ,man-page | |
691 | :switches ',(mapcar #'guix-command-switch->popup-switch switches) | |
692 | :options ',(mapcar #'guix-command-option->popup-option options) | |
693 | :actions ',(mapcar #'guix-command-action->popup-action actions) | |
694 | :max-action-columns 4)))) | |
695 | ||
696 | ;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t) | |
697 | (guix-command-define-popup-action guix) | |
698 | ||
eb097f36 AK |
699 | (defalias 'guix-edit-action #'guix-edit) |
700 | ||
9b0afb0d AK |
701 | \f |
702 | (defvar guix-command-font-lock-keywords | |
703 | (eval-when-compile | |
704 | `((,(rx "(" | |
705 | (group "guix-command-define-" | |
706 | (or "popup-action" | |
707 | "execute-action" | |
708 | "argument-improver")) | |
709 | symbol-end | |
710 | (zero-or-more blank) | |
711 | (zero-or-one | |
712 | (group (one-or-more (or (syntax word) (syntax symbol)))))) | |
713 | (1 font-lock-keyword-face) | |
714 | (2 font-lock-function-name-face nil t))))) | |
715 | ||
716 | (font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords) | |
717 | ||
718 | (provide 'guix-command) | |
719 | ||
720 | ;;; guix-command.el ends here |