emacs/guix-command.el

   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)
  68 (require 'guix-guile)
  69 (require 'guix-external)
  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
 212 (guix-command-define-argument-improver
 213     guix-command-improve-import-argument
 214   '(("cran" :char ?r)))
 215
 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)
 244     ("--key-server" :char ?S)))
 245
 246 (guix-command-define-argument-improver
 247     guix-command-improve-size-argument
 248   '(("--map-file" :fun guix-read-file-name)))
 249
 250 (guix-command-define-argument-improver
 251     guix-command-improve-system-argument
 252   '(("disk-image"  :char ?D)
 253     ("vm-image"    :char ?V)
 254     ("--on-error"  :char ?E)
 255     ("--no-grub"   :char ?g)
 256     ("--full-boot" :char ?b)))
 257
 258 (defvar guix-command-argument-improvers
 259   '((()
 260      guix-command-improve-action-argument)
 261     (("archive")
 262      guix-command-improve-common-build-argument
 263      guix-command-improve-target-argument
 264      guix-command-improve-system-type-argument
 265      guix-command-improve-archive-argument)
 266     (("build")
 267      guix-command-improve-common-build-argument
 268      guix-command-improve-target-argument
 269      guix-command-improve-system-type-argument
 270      guix-command-improve-build-argument)
 271     (("download")
 272      guix-command-improve-hash-argument)
 273     (("hash")
 274      guix-command-improve-hash-argument)
 275     (("environment")
 276      guix-command-improve-common-build-argument
 277      guix-command-improve-search-paths-argument
 278      guix-command-improve-system-type-argument
 279      guix-command-improve-environment-argument)
 280     (("gc")
 281      guix-command-improve-gc-argument)
 282     (("graph")
 283      guix-command-improve-graph-argument)
 284     (("import")
 285      guix-command-improve-import-argument)
 286     (("import" "gnu")
 287      guix-command-improve-key-policy-argument)
 288     (("import" "elpa")
 289      guix-command-improve-import-elpa-argument)
 290     (("lint")
 291      guix-command-improve-lint-argument)
 292     (("package")
 293      guix-command-improve-common-build-argument
 294      guix-command-improve-search-paths-argument
 295      guix-command-improve-package-argument)
 296     (("refresh")
 297      guix-command-improve-key-policy-argument
 298      guix-command-improve-refresh-argument)
 299     (("size")
 300      guix-command-improve-system-type-argument
 301      guix-command-improve-substitute-urls-argument
 302      guix-command-improve-size-argument)
 303     (("system")
 304      guix-command-improve-common-build-argument
 305      guix-command-improve-system-argument))
 306   "Alist of guix commands and argument improvers for them.")
 307
 308 (defun guix-command-improve-argument (argument improvers)
 309   "Return ARGUMENT modified with IMPROVERS."
 310   (or (cl-some (lambda (improver)
 311                  (funcall improver argument))
 312                improvers)
 313       argument))
 314
 315 (defun guix-command-improve-arguments (arguments commands)
 316   "Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface."
 317   (let ((improvers (cons 'guix-command-improve-common-argument
 318                          (guix-assoc-value guix-command-argument-improvers
 319                                            commands))))
 320     (mapcar (lambda (argument)
 321               (guix-command-improve-argument argument improvers))
 322             arguments)))
 323
 324 (defun guix-command-parse-arguments (&optional commands)
 325   "Return a list of parsed 'guix COMMANDS ...' arguments."
 326   (with-temp-buffer
 327     (insert (guix-help-string commands))
 328     (let (args)
 329       (guix-while-search guix-help-parse-option-regexp
 330         (let* ((short (match-string-no-properties 1))
 331                (name  (match-string-no-properties 2))
 332                (arg   (match-string-no-properties 3))
 333                (doc   (match-string-no-properties 4))
 334                (char  (if short
 335                           (elt short 1) ; short option letter
 336                         (elt name 2))) ; first letter of the long option
 337                ;; If "--foo=bar" or "--foo[=bar]" then it is 'option'.
 338                (option? (not (string= "" arg)))
 339                ;; If "--foo" or "--foo[=bar]" then it is 'switch'.
 340                (switch? (or (string= "" arg)
 341                             (eq ?\[ (elt arg 0)))))
 342           (push (guix-command-make-argument
 343                  :name    name
 344                  :char    char
 345                  :doc     doc
 346                  :switch? switch?
 347                  :option? option?)
 348                 args)))
 349       (guix-while-search guix-help-parse-command-regexp
 350         (let* ((name (match-string-no-properties 1))
 351                (char (elt name 0)))
 352           (push (guix-command-make-argument
 353                  :name    name
 354                  :char    char
 355                  :fun     (guix-command-action-name commands name)
 356                  :action? t)
 357                 args)))
 358       args)))
 359
 360 (defun guix-command-rest-argument (&optional commands)
 361   "Return '--' argument for COMMANDS."
 362   (cl-flet ((argument (&rest args)
 363               (apply #'guix-command-make-argument
 364                      :name "-- " :char ?= :option? t args)))
 365     (let ((command (car commands)))
 366       (cond
 367        ((member command
 368                 '("archive" "build" "challenge" "edit" "environment"
 369                   "graph" "lint" "refresh"))
 370         (argument :doc "Packages" :fun 'guix-read-package-names-string))
 371        ((string= command "download")
 372         (argument :doc "URL"))
 373        ((string= command "gc")
 374         (argument :doc "Paths" :fun 'guix-read-file-name))
 375        ((member command '("hash" "system"))
 376         (argument :doc "File" :fun 'guix-read-file-name))
 377        ((string= command "size")
 378         (argument :doc "Package" :fun 'guix-read-package-name))
 379        ((equal commands '("import" "nix"))
 380         (argument :doc "Nixpkgs Attribute"))
 381        ;; Other 'guix import' subcommands, but not 'import' itself.
 382        ((and (cdr commands)
 383              (string= command "import"))
 384         (argument :doc "Package name"))))))
 385
 386 (defun guix-command-additional-arguments (&optional commands)
 387   "Return additional arguments for COMMANDS."
 388   (let ((rest-arg (guix-command-rest-argument commands)))
 389     (and rest-arg (list rest-arg))))
 390
 391 ;; Ideally only `guix-command-arguments' function should exist with the
 392 ;; contents of `guix-command-all-arguments', but we need to make a
 393 ;; special case for `guix-command-complex-with-shared-arguments' commands.
 394
 395 (defun guix-command-all-arguments (&optional commands)
 396   "Return list of all arguments for 'guix COMMANDS ...'."
 397   (let ((parsed (guix-command-parse-arguments commands)))
 398     (append (guix-command-improve-arguments parsed commands)
 399             (guix-command-additional-arguments commands))))
 400
 401 (guix-memoized-defalias guix-command-all-arguments-memoize
 402   guix-command-all-arguments)
 403
 404 (defun guix-command-arguments (&optional commands)
 405   "Return list of arguments for 'guix COMMANDS ...'."
 406   (let ((command (car commands)))
 407     (if (member command
 408                 guix-command-complex-with-shared-arguments)
 409         ;; Take actions only for 'guix system', and switches+options for
 410         ;; 'guix system foo'.
 411         (funcall (if (null (cdr commands))
 412                      #'cl-remove-if-not
 413                    #'cl-remove-if)
 414                  #'guix-command-argument-action?
 415                  (guix-command-all-arguments-memoize (list command)))
 416       (guix-command-all-arguments commands))))
 417
 418 (defun guix-command-switch->popup-switch (switch)
 419   "Return popup switch from command SWITCH argument."
 420   (list (guix-command-argument-char switch)
 421         (or (guix-command-argument-doc switch)
 422             "Unknown")
 423         (guix-command-argument-name switch)))
 424
 425 (defun guix-command-option->popup-option (option)
 426   "Return popup option from command OPTION argument."
 427   (list (guix-command-argument-char option)
 428         (or (guix-command-argument-doc option)
 429             "Unknown")
 430         (let ((name (guix-command-argument-name option)))
 431           (if (string-match-p " \\'" name) ; ends with space
 432               name
 433             (concat name "=")))
 434         (or (guix-command-argument-fun option)
 435             'read-from-minibuffer)))
 436
 437 (defun guix-command-action->popup-action (action)
 438   "Return popup action from command ACTION argument."
 439   (list (guix-command-argument-char action)
 440         (or (guix-command-argument-doc action)
 441             (guix-command-argument-name action)
 442             "Unknown")
 443         (guix-command-argument-fun action)))
 444
 445 (defun guix-command-sort-arguments (arguments)
 446   "Sort ARGUMENTS by name in alphabetical order."
 447   (sort arguments
 448         (lambda (a1 a2)
 449           (let ((name1 (guix-command-argument-name a1))
 450                 (name2 (guix-command-argument-name a2)))
 451             (cond ((null name1) nil)
 452                   ((null name2) t)
 453                   (t (string< name1 name2)))))))
 454
 455 (defun guix-command-switches (arguments)
 456   "Return switches from ARGUMENTS."
 457   (cl-remove-if-not #'guix-command-argument-switch? arguments))
 458
 459 (defun guix-command-options (arguments)
 460   "Return options from ARGUMENTS."
 461   (cl-remove-if-not #'guix-command-argument-option? arguments))
 462
 463 (defun guix-command-actions (arguments)
 464   "Return actions from ARGUMENTS."
 465   (cl-remove-if-not #'guix-command-argument-action? arguments))
 466
 467 (defun guix-command-post-process-args (args)
 468   "Adjust appropriately command line ARGS returned from popup command."
 469   ;; XXX We need to split "--install foo bar" and similar strings into
 470   ;; lists of strings.  But some commands (e.g., 'guix hash') accept a
 471   ;; file name as the 'rest' argument, and as file names may contain
 472   ;; spaces, splitting by spaces will break such names.  For example, the
 473   ;; following argument: "-- /tmp/file with spaces" will be transformed
 474   ;; into the following list: ("--" "/tmp/file" "with" "spaces") instead
 475   ;; of the wished ("--" "/tmp/file with spaces").
 476   (let* (rest
 477          (rx (rx string-start
 478                  (or "-- " "--install " "--remove ")))
 479          (args (mapcar (lambda (arg)
 480                          (if (string-match-p rx arg)
 481                              (progn (push (split-string arg) rest)
 482                                     nil)
 483                            arg))
 484                        args)))
 485     (if rest
 486         (apply #'append (delq nil args) rest)
 487       args)))
 488
 489 \f
 490 ;;; 'Execute' actions
 491
 492 (defvar guix-command-default-execute-arguments
 493   (list
 494    (guix-command-make-argument
 495     :name "repl"  :char ?r :doc "Run in Guix REPL")
 496    (guix-command-make-argument
 497     :name "shell" :char ?s :doc "Run in shell")
 498    (guix-command-make-argument
 499     :name "copy"  :char ?c :doc "Copy command line"))
 500   "List of default 'execute' action arguments.")
 501
 502 (defvar guix-command-additional-execute-arguments
 503   (let ((graph-arg (guix-command-make-argument
 504                     :name "view" :char ?v :doc "View graph")))
 505     `((("build")
 506        ,(guix-command-make-argument
 507          :name "log" :char ?l :doc "View build log"))
 508       (("graph") ,graph-arg)
 509       (("size")
 510        ,(guix-command-make-argument
 511          :name "view" :char ?v :doc "View map"))
 512       (("system" "dmd-graph") ,graph-arg)
 513       (("system" "extension-graph") ,graph-arg)))
 514   "Alist of guix commands and additional 'execute' action arguments.")
 515
 516 (defun guix-command-execute-arguments (commands)
 517   "Return a list of 'execute' action arguments for COMMANDS."
 518   (mapcar (lambda (arg)
 519             (guix-command-modify-argument arg
 520               :action? t
 521               :fun (guix-command-action-name
 522                     commands (guix-command-argument-name arg))))
 523           (append guix-command-default-execute-arguments
 524                   (guix-assoc-value
 525                    guix-command-additional-execute-arguments commands))))
 526
 527 (defvar guix-command-special-executors
 528   '((("environment")
 529      ("repl" . guix-run-environment-command-in-repl))
 530     (("pull")
 531      ("repl" . guix-run-pull-command-in-repl))
 532     (("build")
 533      ("log" . guix-run-view-build-log))
 534     (("graph")
 535      ("view" . guix-run-view-graph))
 536     (("size")
 537      ("view" . guix-run-view-size-map))
 538     (("system" "dmd-graph")
 539      ("view" . guix-run-view-graph))
 540     (("system" "extension-graph")
 541      ("view" . guix-run-view-graph)))
 542   "Alist of guix commands and alists of special executers for them.
 543 See also `guix-command-default-executors'.")
 544
 545 (defvar guix-command-default-executors
 546   '(("repl"  . guix-run-command-in-repl)
 547     ("shell" . guix-run-command-in-shell)
 548     ("copy"  . guix-copy-command-as-kill))
 549   "Alist of default executers for action names.")
 550
 551 (defun guix-command-executor (commands name)
 552   "Return function to run command line arguments for guix COMMANDS."
 553   (or (guix-assoc-value guix-command-special-executors commands name)
 554       (guix-assoc-value guix-command-default-executors name)))
 555
 556 (defun guix-run-environment-command-in-repl (args)
 557   "Run 'guix ARGS ...' environment command in Guix REPL."
 558   ;; As 'guix environment' usually tries to run another process, it may
 559   ;; be fun but not wise to run this command in Geiser REPL.
 560   (when (or (member "--dry-run" args)
 561             (member "--search-paths" args)
 562             (when (y-or-n-p
 563                    (format "'%s' command will spawn an external process.
 564 Do you really want to execute this command in Geiser REPL? "
 565                            (guix-command-string args)))
 566               (message "May \"M-x shell-mode\" be with you!")
 567               t))
 568     (guix-run-command-in-repl args)))
 569
 570 (defun guix-run-pull-command-in-repl (args)
 571   "Run 'guix ARGS ...' pull command in Guix REPL.
 572 Perform pull-specific actions after operation, see
 573 `guix-after-pull-hook' and `guix-update-after-pull'."
 574   (guix-eval-in-repl
 575    (apply #'guix-make-guile-expression 'guix-command args)
 576    nil 'pull))
 577
 578 (defun guix-run-view-build-log (args)
 579   "Add --log-file to ARGS, run 'guix ARGS ...' build command, and
 580 open the log file(s)."
 581   (let* ((args (if (member "--log-file" args)
 582                    args
 583                  (apply #'list (car args) "--log-file" (cdr args))))
 584          (output (guix-command-output args))
 585          (files  (split-string output "\n" t)))
 586     (dolist (file files)
 587       (guix-find-file-or-url file)
 588       (guix-build-log-mode))))
 589
 590 (defun guix-run-view-graph (args)
 591   "Run 'guix ARGS ...' graph command, make the image and open it."
 592   (let* ((graph-file (guix-dot-file-name))
 593          (dot-args   (guix-dot-arguments graph-file)))
 594     (if (guix-eval-read (guix-make-guile-expression
 595                          'pipe-guix-output args dot-args))
 596         (guix-find-file graph-file)
 597       (error "Couldn't create a graph"))))
 598
 599 (defun guix-run-view-size-map (args)
 600   "Run 'guix ARGS ...' size command, and open the map file."
 601   (let* ((wished-map-file
 602           (cl-some (lambda (arg)
 603                      (and (string-match "--map-file=\\(.+\\)" arg)
 604                           (match-string 1 arg)))
 605                    args))
 606          (map-file (or wished-map-file (guix-png-file-name)))
 607          (args (if wished-map-file
 608                    args
 609                  (apply #'list
 610                         (car args)
 611                         (concat "--map-file=" map-file)
 612                         (cdr args)))))
 613     (guix-command-output args)
 614     (guix-find-file map-file)))
 615
 616 \f
 617 ;;; Generating popups, actions, etc.
 618
 619 (defmacro guix-command-define-popup-action (name &optional commands)
 620   "Define NAME function to generate (if needed) and run popup for COMMANDS."
 621   (declare (indent 1) (debug t))
 622   (let* ((popup-fun (guix-command-symbol `(,@commands "popup")))
 623          (doc (format "Call `%s' (generate it if needed)."
 624                       popup-fun)))
 625     `(defun ,name (&optional arg)
 626        ,doc
 627        (interactive "P")
 628        (unless (fboundp ',popup-fun)
 629          (guix-command-generate-popup ',popup-fun ',commands))
 630        (,popup-fun arg))))
 631
 632 (defmacro guix-command-define-execute-action (name executor
 633                                                    &optional commands)
 634   "Define NAME function to execute the current action for guix COMMANDS.
 635 EXECUTOR function is called with the current command line arguments."
 636   (declare (indent 1) (debug t))
 637   (let* ((arguments-fun (guix-command-symbol `(,@commands "arguments")))
 638          (doc (format "Call `%s' with the current popup arguments."
 639                       executor)))
 640     `(defun ,name (&rest args)
 641        ,doc
 642        (interactive (,arguments-fun))
 643        (,executor (append ',commands
 644                           (guix-command-post-process-args args))))))
 645
 646 (defun guix-command-generate-popup-actions (actions &optional commands)
 647   "Generate 'popup' commands from ACTIONS arguments for guix COMMANDS."
 648   (dolist (action actions)
 649     (let ((fun (guix-command-argument-fun action)))
 650       (unless (fboundp fun)
 651         (eval `(guix-command-define-popup-action ,fun
 652                  ,(append commands
 653                           (list (guix-command-argument-name action)))))))))
 654
 655 (defun guix-command-generate-execute-actions (actions &optional commands)
 656   "Generate 'execute' commands from ACTIONS arguments for guix COMMANDS."
 657   (dolist (action actions)
 658     (let ((fun (guix-command-argument-fun action)))
 659       (unless (fboundp fun)
 660         (eval `(guix-command-define-execute-action ,fun
 661                  ,(guix-command-executor
 662                    commands (guix-command-argument-name action))
 663                  ,commands))))))
 664
 665 (defun guix-command-generate-popup (name &optional commands)
 666   "Define NAME popup with 'guix COMMANDS ...' interface."
 667   (let* ((command  (car commands))
 668          (man-page (concat "guix" (and command (concat "-" command))))
 669          (doc      (format "Popup window for '%s' command."
 670                            (guix-concat-strings (cons "guix" commands)
 671                                                 " ")))
 672          (args     (guix-command-arguments commands))
 673          (switches (guix-command-sort-arguments
 674                     (guix-command-switches args)))
 675          (options  (guix-command-sort-arguments
 676                     (guix-command-options args)))
 677          (popup-actions (guix-command-sort-arguments
 678                          (guix-command-actions args)))
 679          (execute-actions (unless popup-actions
 680                             (guix-command-execute-arguments commands)))
 681          (actions (or popup-actions execute-actions)))
 682     (if popup-actions
 683         (guix-command-generate-popup-actions popup-actions commands)
 684       (guix-command-generate-execute-actions execute-actions commands))
 685     (eval
 686      `(guix-define-popup ,name
 687         ,doc
 688         'guix-commands
 689         :man-page ,man-page
 690         :switches ',(mapcar #'guix-command-switch->popup-switch switches)
 691         :options  ',(mapcar #'guix-command-option->popup-option options)
 692         :actions  ',(mapcar #'guix-command-action->popup-action actions)
 693         :max-action-columns 4))))
 694
 695 ;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t)
 696 (guix-command-define-popup-action guix)
 697
 698 (defalias 'guix-edit-action #'guix-edit)
 699
 700 \f
 701 (defvar guix-command-font-lock-keywords
 702   (eval-when-compile
 703     `((,(rx "("
 704             (group "guix-command-define-"
 705                    (or "popup-action"
 706                        "execute-action"
 707                        "argument-improver"))
 708             symbol-end
 709             (zero-or-more blank)
 710             (zero-or-one
 711              (group (one-or-more (or (syntax word) (syntax symbol))))))
 712        (1 font-lock-keyword-face)
 713        (2 font-lock-function-name-face nil t)))))
 714
 715 (font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords)
 716
 717 (provide 'guix-command)
 718
 719 ;;; guix-command.el ends here