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     ("--type"       :fun guix-read-refresh-updater-names-string)
 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
 253   '(("disk-image"  :char ?D)
 254     ("vm-image"    :char ?V)
 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)
 285     (("import")
 286      guix-command-improve-import-argument)
 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."
 311   (or (cl-some (lambda (improver)
 312                  (funcall improver argument))
 313                improvers)
 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
 368        ((member command
 369                 '("archive" "build" "challenge" "edit" "environment"
 370                   "graph" "lint" "refresh"))
 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
 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)))
 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")
 532      ("repl" . guix-run-pull-command-in-repl))
 533     (("build")
 534      ("log" . guix-run-view-build-log))
 535     (("graph")
 536      ("view" . guix-run-view-graph))
 537     (("size")
 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)))
 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
 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
 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
 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
 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
 699 (defalias 'guix-edit-action #'guix-edit)
 700
 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