| 1 | ;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- |
| 2 | |
| 3 | ;; Copyright © 2015, 2016 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) |
| 68 | (require 'guix-build-log) |
| 69 | (require 'guix-guile) |
| 70 | (require 'guix-external) |
| 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 |
| 135 | '(("container" :char ?C) |
| 136 | ("graph" :char ?G) |
| 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) |
| 178 | ("--max-silent-time" :char ?x) |
| 179 | ("--rounds" :char ?R :fun read-number) |
| 180 | ("--with-input" :char ?W))) |
| 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) |
| 196 | ("--file" :fun guix-read-file-name) |
| 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 |
| 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) |
| 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 | |
| 221 | (guix-command-define-argument-improver |
| 222 | guix-command-improve-import-argument |
| 223 | '(("cran" :char ?r))) |
| 224 | |
| 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) |
| 246 | ("--profile" :fun guix-read-file-name) |
| 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) |
| 254 | ("--type" :fun guix-read-refresh-updater-names-string) |
| 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 |
| 263 | '(("disk-image" :char ?D) |
| 264 | ("vm-image" :char ?V) |
| 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) |
| 295 | (("import") |
| 296 | guix-command-improve-import-argument) |
| 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." |
| 321 | (or (cl-some (lambda (improver) |
| 322 | (funcall improver argument)) |
| 323 | improvers) |
| 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 |
| 378 | ((member command |
| 379 | '("archive" "build" "challenge" "edit" |
| 380 | "graph" "lint" "refresh")) |
| 381 | (argument :doc "Packages" :fun 'guix-read-package-names-string)) |
| 382 | ((equal commands '("container" "exec")) |
| 383 | (argument :doc "PID Command [Args...]")) |
| 384 | ((string= command "download") |
| 385 | (argument :doc "URL")) |
| 386 | ((string= command "environment") |
| 387 | (argument :doc "Command [Args...]" :fun 'read-shell-command)) |
| 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 | |
| 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 | |
| 411 | (defun guix-command-additional-arguments (&optional commands) |
| 412 | "Return additional arguments for COMMANDS." |
| 413 | (let ((rest-arg (guix-command-rest-argument commands))) |
| 414 | (append (guix-assoc-value guix-command-additional-arguments |
| 415 | commands) |
| 416 | (and rest-arg (list rest-arg))))) |
| 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 | |
| 494 | \f |
| 495 | ;;; Post processing popup arguments |
| 496 | |
| 497 | (defvar guix-command-post-processors |
| 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" |
| 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) |
| 522 | (args (mapcar (lambda (arg) |
| 523 | (if (funcall predicate arg) |
| 524 | (progn |
| 525 | (push (funcall modifier arg) rest) |
| 526 | nil) |
| 527 | arg)) |
| 528 | args))) |
| 529 | (if rest |
| 530 | (apply #'append (delq nil args) rest) |
| 531 | args))) |
| 532 | |
| 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 | |
| 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 | |
| 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 | |
| 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 |
| 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")) |
| 624 | (("system" "shepherd-graph") ,graph-arg) |
| 625 | (("system" "extension-graph") ,graph-arg))) |
| 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") |
| 643 | ("repl" . guix-run-pull-command-in-repl)) |
| 644 | (("build") |
| 645 | ("log" . guix-run-view-build-log)) |
| 646 | (("graph") |
| 647 | ("view" . guix-run-view-graph)) |
| 648 | (("size") |
| 649 | ("view" . guix-run-view-size-map)) |
| 650 | (("system" "shepherd-graph") |
| 651 | ("view" . guix-run-view-graph)) |
| 652 | (("system" "extension-graph") |
| 653 | ("view" . guix-run-view-graph))) |
| 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 | |
| 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 |
| 695 | (cl-list* (car args) "--log-file" (cdr args)))) |
| 696 | (output (guix-command-output args)) |
| 697 | (files (split-string output "\n" t))) |
| 698 | (dolist (file files) |
| 699 | (guix-build-log-find-file file)))) |
| 700 | |
| 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 | |
| 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 |
| 720 | (cl-list* (car args) |
| 721 | (concat "--map-file=" map-file) |
| 722 | (cdr args))))) |
| 723 | (guix-command-output args) |
| 724 | (guix-find-file map-file))) |
| 725 | |
| 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 |
| 754 | (guix-command-post-process-args |
| 755 | ',commands args)))))) |
| 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 | |
| 809 | (defalias 'guix-edit-action #'guix-edit) |
| 810 | |
| 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 |