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   '(("container"   :char ?C)
 135     ("graph"       :char ?G)
 136     ("environment" :char ?E)
 137     ("publish"     :char ?u)
 138     ("pull"        :char ?P)
 139     ("size"        :char ?z)))
 140
 141 (guix-command-define-argument-improver
 142     guix-command-improve-common-argument
 143   '(("--help"    :switch? nil)
 144     ("--version" :switch? nil)))
 145
 146 (guix-command-define-argument-improver
 147     guix-command-improve-target-argument
 148   '(("--target" :char ?T)))
 149
 150 (guix-command-define-argument-improver
 151     guix-command-improve-system-type-argument
 152   '(("--system" :fun guix-read-system-type)))
 153
 154 (guix-command-define-argument-improver
 155     guix-command-improve-load-path-argument
 156   '(("--load-path" :fun read-directory-name)))
 157
 158 (guix-command-define-argument-improver
 159     guix-command-improve-search-paths-argument
 160   '(("--search-paths" :char ?P)))
 161
 162 (guix-command-define-argument-improver
 163     guix-command-improve-substitute-urls-argument
 164   '(("--substitute-urls" :char ?U)))
 165
 166 (guix-command-define-argument-improver
 167     guix-command-improve-hash-argument
 168   '(("--format" :fun guix-read-hash-format)))
 169
 170 (guix-command-define-argument-improver
 171     guix-command-improve-key-policy-argument
 172   '(("--key-download" :fun guix-read-key-policy)))
 173
 174 (defvar guix-command-improve-common-build-argument
 175   '(("--no-substitutes"  :char ?s)
 176     ("--no-build-hook"   :char ?h)
 177     ("--max-silent-time" :char ?x)))
 178
 179 (defun guix-command-improve-common-build-argument (argument)
 180   (guix-command-modify-argument-from-alist
 181    argument
 182    (append guix-command-improve-load-path-argument
 183            guix-command-improve-substitute-urls-argument
 184            guix-command-improve-common-build-argument)))
 185
 186 (guix-command-define-argument-improver
 187     guix-command-improve-archive-argument
 188   '(("--generate-key" :char ?k)))
 189
 190 (guix-command-define-argument-improver
 191     guix-command-improve-build-argument
 192   '(("--no-grafts"   :char ?g)
 193     ("--root"        :fun guix-read-file-name)
 194     ("--sources"     :char ?S :fun guix-read-source-type :switch? nil)
 195     ("--with-source" :fun guix-read-file-name)))
 196
 197 (guix-command-define-argument-improver
 198     guix-command-improve-environment-argument
 199   '(("--exec" :fun read-shell-command)
 200     ("--load" :fun guix-read-file-name)))
 201
 202 (guix-command-define-argument-improver
 203     guix-command-improve-gc-argument
 204   '(("--list-dead" :char ?D)
 205     ("--list-live" :char ?L)
 206     ("--referrers" :char ?f)
 207     ("--verify"    :fun guix-read-verify-options-string)))
 208
 209 (guix-command-define-argument-improver
 210     guix-command-improve-graph-argument
 211   '(("--type" :fun guix-read-graph-type)))
 212
 213 (guix-command-define-argument-improver
 214     guix-command-improve-import-argument
 215   '(("cran" :char ?r)))
 216
 217 (guix-command-define-argument-improver
 218     guix-command-improve-import-elpa-argument
 219   '(("--archive" :fun guix-read-elpa-archive)))
 220
 221 (guix-command-define-argument-improver
 222     guix-command-improve-lint-argument
 223   '(("--checkers" :fun guix-read-lint-checker-names-string)))
 224
 225 (guix-command-define-argument-improver
 226     guix-command-improve-package-argument
 227   ;; Unlike all other options, --install/--remove do not have a form
 228   ;; '--install=foo,bar' but '--install foo bar' instead, so we need
 229   ;; some tweaks.
 230   '(("--install"
 231      :name "--install " :fun guix-read-package-names-string
 232      :switch? nil :option? t)
 233     ("--remove"
 234      :name "--remove "  :fun guix-read-package-names-string
 235      :switch? nil :option? t)
 236     ("--install-from-file" :fun guix-read-file-name)
 237     ("--manifest"       :fun guix-read-file-name)
 238     ("--do-not-upgrade" :char ?U)
 239     ("--roll-back"      :char ?R)
 240     ("--show"           :char ?w :fun guix-read-package-name)))
 241
 242 (guix-command-define-argument-improver
 243     guix-command-improve-refresh-argument
 244   '(("--select"     :fun guix-read-refresh-subset)
 245     ("--type"       :fun guix-read-refresh-updater-names-string)
 246     ("--key-server" :char ?S)))
 247
 248 (guix-command-define-argument-improver
 249     guix-command-improve-size-argument
 250   '(("--map-file" :fun guix-read-file-name)))
 251
 252 (guix-command-define-argument-improver
 253     guix-command-improve-system-argument
 254   '(("disk-image"  :char ?D)
 255     ("vm-image"    :char ?V)
 256     ("--on-error"  :char ?E)
 257     ("--no-grub"   :char ?g)
 258     ("--full-boot" :char ?b)))
 259
 260 (defvar guix-command-argument-improvers
 261   '((()
 262      guix-command-improve-action-argument)
 263     (("archive")
 264      guix-command-improve-common-build-argument
 265      guix-command-improve-target-argument
 266      guix-command-improve-system-type-argument
 267      guix-command-improve-archive-argument)
 268     (("build")
 269      guix-command-improve-common-build-argument
 270      guix-command-improve-target-argument
 271      guix-command-improve-system-type-argument
 272      guix-command-improve-build-argument)
 273     (("download")
 274      guix-command-improve-hash-argument)
 275     (("hash")
 276      guix-command-improve-hash-argument)
 277     (("environment")
 278      guix-command-improve-common-build-argument
 279      guix-command-improve-search-paths-argument
 280      guix-command-improve-system-type-argument
 281      guix-command-improve-environment-argument)
 282     (("gc")
 283      guix-command-improve-gc-argument)
 284     (("graph")
 285      guix-command-improve-graph-argument)
 286     (("import")
 287      guix-command-improve-import-argument)
 288     (("import" "gnu")
 289      guix-command-improve-key-policy-argument)
 290     (("import" "elpa")
 291      guix-command-improve-import-elpa-argument)
 292     (("lint")
 293      guix-command-improve-lint-argument)
 294     (("package")
 295      guix-command-improve-common-build-argument
 296      guix-command-improve-search-paths-argument
 297      guix-command-improve-package-argument)
 298     (("refresh")
 299      guix-command-improve-key-policy-argument
 300      guix-command-improve-refresh-argument)
 301     (("size")
 302      guix-command-improve-system-type-argument
 303      guix-command-improve-substitute-urls-argument
 304      guix-command-improve-size-argument)
 305     (("system")
 306      guix-command-improve-common-build-argument
 307      guix-command-improve-system-argument))
 308   "Alist of guix commands and argument improvers for them.")
 309
 310 (defun guix-command-improve-argument (argument improvers)
 311   "Return ARGUMENT modified with IMPROVERS."
 312   (or (cl-some (lambda (improver)
 313                  (funcall improver argument))
 314                improvers)
 315       argument))
 316
 317 (defun guix-command-improve-arguments (arguments commands)
 318   "Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface."
 319   (let ((improvers (cons 'guix-command-improve-common-argument
 320                          (guix-assoc-value guix-command-argument-improvers
 321                                            commands))))
 322     (mapcar (lambda (argument)
 323               (guix-command-improve-argument argument improvers))
 324             arguments)))
 325
 326 (defun guix-command-parse-arguments (&optional commands)
 327   "Return a list of parsed 'guix COMMANDS ...' arguments."
 328   (with-temp-buffer
 329     (insert (guix-help-string commands))
 330     (let (args)
 331       (guix-while-search guix-help-parse-option-regexp
 332         (let* ((short (match-string-no-properties 1))
 333                (name  (match-string-no-properties 2))
 334                (arg   (match-string-no-properties 3))
 335                (doc   (match-string-no-properties 4))
 336                (char  (if short
 337                           (elt short 1) ; short option letter
 338                         (elt name 2))) ; first letter of the long option
 339                ;; If "--foo=bar" or "--foo[=bar]" then it is 'option'.
 340                (option? (not (string= "" arg)))
 341                ;; If "--foo" or "--foo[=bar]" then it is 'switch'.
 342                (switch? (or (string= "" arg)
 343                             (eq ?\[ (elt arg 0)))))
 344           (push (guix-command-make-argument
 345                  :name    name
 346                  :char    char
 347                  :doc     doc
 348                  :switch? switch?
 349                  :option? option?)
 350                 args)))
 351       (guix-while-search guix-help-parse-command-regexp
 352         (let* ((name (match-string-no-properties 1))
 353                (char (elt name 0)))
 354           (push (guix-command-make-argument
 355                  :name    name
 356                  :char    char
 357                  :fun     (guix-command-action-name commands name)
 358                  :action? t)
 359                 args)))
 360       args)))
 361
 362 (defun guix-command-rest-argument (&optional commands)
 363   "Return '--' argument for COMMANDS."
 364   (cl-flet ((argument (&rest args)
 365               (apply #'guix-command-make-argument
 366                      :name "-- " :char ?= :option? t args)))
 367     (let ((command (car commands)))
 368       (cond
 369        ((member command
 370                 '("archive" "build" "challenge" "edit" "environment"
 371                   "graph" "lint" "refresh"))
 372         (argument :doc "Packages" :fun 'guix-read-package-names-string))
 373        ((equal commands '("container" "exec"))
 374         (argument :doc "PID Command [Args...]"))
 375        ((string= command "download")
 376         (argument :doc "URL"))
 377        ((string= command "gc")
 378         (argument :doc "Paths" :fun 'guix-read-file-name))
 379        ((member command '("hash" "system"))
 380         (argument :doc "File" :fun 'guix-read-file-name))
 381        ((string= command "size")
 382         (argument :doc "Package" :fun 'guix-read-package-name))
 383        ((equal commands '("import" "nix"))
 384         (argument :doc "Nixpkgs Attribute"))
 385        ;; Other 'guix import' subcommands, but not 'import' itself.
 386        ((and (cdr commands)
 387              (string= command "import"))
 388         (argument :doc "Package name"))))))
 389
 390 (defun guix-command-additional-arguments (&optional commands)
 391   "Return additional arguments for COMMANDS."
 392   (let ((rest-arg (guix-command-rest-argument commands)))
 393     (and rest-arg (list rest-arg))))
 394
 395 ;; Ideally only `guix-command-arguments' function should exist with the
 396 ;; contents of `guix-command-all-arguments', but we need to make a
 397 ;; special case for `guix-command-complex-with-shared-arguments' commands.
 398
 399 (defun guix-command-all-arguments (&optional commands)
 400   "Return list of all arguments for 'guix COMMANDS ...'."
 401   (let ((parsed (guix-command-parse-arguments commands)))
 402     (append (guix-command-improve-arguments parsed commands)
 403             (guix-command-additional-arguments commands))))
 404
 405 (guix-memoized-defalias guix-command-all-arguments-memoize
 406   guix-command-all-arguments)
 407
 408 (defun guix-command-arguments (&optional commands)
 409   "Return list of arguments for 'guix COMMANDS ...'."
 410   (let ((command (car commands)))
 411     (if (member command
 412                 guix-command-complex-with-shared-arguments)
 413         ;; Take actions only for 'guix system', and switches+options for
 414         ;; 'guix system foo'.
 415         (funcall (if (null (cdr commands))
 416                      #'cl-remove-if-not
 417                    #'cl-remove-if)
 418                  #'guix-command-argument-action?
 419                  (guix-command-all-arguments-memoize (list command)))
 420       (guix-command-all-arguments commands))))
 421
 422 (defun guix-command-switch->popup-switch (switch)
 423   "Return popup switch from command SWITCH argument."
 424   (list (guix-command-argument-char switch)
 425         (or (guix-command-argument-doc switch)
 426             "Unknown")
 427         (guix-command-argument-name switch)))
 428
 429 (defun guix-command-option->popup-option (option)
 430   "Return popup option from command OPTION argument."
 431   (list (guix-command-argument-char option)
 432         (or (guix-command-argument-doc option)
 433             "Unknown")
 434         (let ((name (guix-command-argument-name option)))
 435           (if (string-match-p " \\'" name) ; ends with space
 436               name
 437             (concat name "=")))
 438         (or (guix-command-argument-fun option)
 439             'read-from-minibuffer)))
 440
 441 (defun guix-command-action->popup-action (action)
 442   "Return popup action from command ACTION argument."
 443   (list (guix-command-argument-char action)
 444         (or (guix-command-argument-doc action)
 445             (guix-command-argument-name action)
 446             "Unknown")
 447         (guix-command-argument-fun action)))
 448
 449 (defun guix-command-sort-arguments (arguments)
 450   "Sort ARGUMENTS by name in alphabetical order."
 451   (sort arguments
 452         (lambda (a1 a2)
 453           (let ((name1 (guix-command-argument-name a1))
 454                 (name2 (guix-command-argument-name a2)))
 455             (cond ((null name1) nil)
 456                   ((null name2) t)
 457                   (t (string< name1 name2)))))))
 458
 459 (defun guix-command-switches (arguments)
 460   "Return switches from ARGUMENTS."
 461   (cl-remove-if-not #'guix-command-argument-switch? arguments))
 462
 463 (defun guix-command-options (arguments)
 464   "Return options from ARGUMENTS."
 465   (cl-remove-if-not #'guix-command-argument-option? arguments))
 466
 467 (defun guix-command-actions (arguments)
 468   "Return actions from ARGUMENTS."
 469   (cl-remove-if-not #'guix-command-argument-action? arguments))
 470
 471 \f
 472 ;;; Post processing popup arguments
 473
 474 (defvar guix-command-post-processors
 475   '(("hash"
 476      guix-command-post-process-rest-single)
 477     ("package"
 478      guix-command-post-process-package-args)
 479     ("system"
 480      guix-command-post-process-rest-single))
 481   "Alist of guix commands and functions for post-processing
 482 a list of arguments returned from popup interface.
 483 Each function is called on the returned arguments in turn.")
 484
 485 (defvar guix-command-rest-arg-regexp
 486   (rx string-start "-- " (group (+ any)))
 487   "Regexp to match a string with the 'rest' arguments.")
 488
 489 (defun guix-command-replace-args (args predicate modifier)
 490   "Replace arguments matching PREDICATE from ARGS.
 491 Call MODIFIER on each argument matching PREDICATE and append the
 492 returned list of strings to the end of ARGS.  Remove the original
 493 arguments."
 494   (let* ((rest nil)
 495          (args (mapcar (lambda (arg)
 496                          (if (funcall predicate arg)
 497                              (progn
 498                                (push (funcall modifier arg) rest)
 499                                nil)
 500                            arg))
 501                        args)))
 502     (if rest
 503         (apply #'append (delq nil args) rest)
 504       args)))
 505
 506 (cl-defun guix-command-post-process-matching-args (args regexp
 507                                                    &key group split?)
 508   "Modify arguments from ARGS matching REGEXP by moving them to
 509 the end of ARGS list.  If SPLIT? is non-nil, split matching
 510 arguments into multiple subarguments."
 511   (guix-command-replace-args
 512    args
 513    (lambda (arg)
 514      (string-match regexp arg))
 515    (lambda (arg)
 516      (let ((val (match-string (or group 0) arg))
 517            (fun (if split? #'split-string #'list)))
 518        (funcall fun val)))))
 519
 520 (defun guix-command-post-process-rest-single (args)
 521   "Modify ARGS by moving '-- ARG' argument to the end of ARGS list."
 522   (guix-command-post-process-matching-args
 523    args guix-command-rest-arg-regexp
 524    :group 1))
 525
 526 (defun guix-command-post-process-rest-multiple (args)
 527   "Modify ARGS by splitting '-- ARG ...' into multiple subarguments
 528 and moving them to the end of ARGS list.
 529 Remove '-- ' string."
 530   (guix-command-post-process-matching-args
 531    args guix-command-rest-arg-regexp
 532    :group 1
 533    :split? t))
 534
 535 (defun guix-command-post-process-rest-multiple-leave (args)
 536   "Modify ARGS by splitting '-- ARG ...' into multiple subarguments
 537 and moving them to the end of ARGS list.
 538 Leave '--' string as a separate argument."
 539   (guix-command-post-process-matching-args
 540    args guix-command-rest-arg-regexp
 541    :split? t))
 542
 543 (defun guix-command-post-process-package-args (args)
 544   "Adjust popup ARGS for 'guix package' command."
 545   (guix-command-post-process-matching-args
 546    args (rx string-start (or "--install " "--remove ") (+ any))
 547    :split? t))
 548
 549 (defun guix-command-post-process-args (commands args)
 550   "Adjust popup ARGS for guix COMMANDS."
 551   (let* ((command (car commands))
 552          (processors
 553           (append (guix-assoc-value guix-command-post-processors commands)
 554                   (guix-assoc-value guix-command-post-processors command))))
 555     (guix-modify args
 556                  (or processors
 557                      (list #'guix-command-post-process-rest-multiple)))))
 558
 559 \f
 560 ;;; 'Execute' actions
 561
 562 (defvar guix-command-default-execute-arguments
 563   (list
 564    (guix-command-make-argument
 565     :name "repl"  :char ?r :doc "Run in Guix REPL")
 566    (guix-command-make-argument
 567     :name "shell" :char ?s :doc "Run in shell")
 568    (guix-command-make-argument
 569     :name "copy"  :char ?c :doc "Copy command line"))
 570   "List of default 'execute' action arguments.")
 571
 572 (defvar guix-command-additional-execute-arguments
 573   (let ((graph-arg (guix-command-make-argument
 574                     :name "view" :char ?v :doc "View graph")))
 575     `((("build")
 576        ,(guix-command-make-argument
 577          :name "log" :char ?l :doc "View build log"))
 578       (("graph") ,graph-arg)
 579       (("size")
 580        ,(guix-command-make-argument
 581          :name "view" :char ?v :doc "View map"))
 582       (("system" "dmd-graph") ,graph-arg)
 583       (("system" "extension-graph") ,graph-arg)))
 584   "Alist of guix commands and additional 'execute' action arguments.")
 585
 586 (defun guix-command-execute-arguments (commands)
 587   "Return a list of 'execute' action arguments for COMMANDS."
 588   (mapcar (lambda (arg)
 589             (guix-command-modify-argument arg
 590               :action? t
 591               :fun (guix-command-action-name
 592                     commands (guix-command-argument-name arg))))
 593           (append guix-command-default-execute-arguments
 594                   (guix-assoc-value
 595                    guix-command-additional-execute-arguments commands))))
 596
 597 (defvar guix-command-special-executors
 598   '((("environment")
 599      ("repl" . guix-run-environment-command-in-repl))
 600     (("pull")
 601      ("repl" . guix-run-pull-command-in-repl))
 602     (("build")
 603      ("log" . guix-run-view-build-log))
 604     (("graph")
 605      ("view" . guix-run-view-graph))
 606     (("size")
 607      ("view" . guix-run-view-size-map))
 608     (("system" "dmd-graph")
 609      ("view" . guix-run-view-graph))
 610     (("system" "extension-graph")
 611      ("view" . guix-run-view-graph)))
 612   "Alist of guix commands and alists of special executers for them.
 613 See also `guix-command-default-executors'.")
 614
 615 (defvar guix-command-default-executors
 616   '(("repl"  . guix-run-command-in-repl)
 617     ("shell" . guix-run-command-in-shell)
 618     ("copy"  . guix-copy-command-as-kill))
 619   "Alist of default executers for action names.")
 620
 621 (defun guix-command-executor (commands name)
 622   "Return function to run command line arguments for guix COMMANDS."
 623   (or (guix-assoc-value guix-command-special-executors commands name)
 624       (guix-assoc-value guix-command-default-executors name)))
 625
 626 (defun guix-run-environment-command-in-repl (args)
 627   "Run 'guix ARGS ...' environment command in Guix REPL."
 628   ;; As 'guix environment' usually tries to run another process, it may
 629   ;; be fun but not wise to run this command in Geiser REPL.
 630   (when (or (member "--dry-run" args)
 631             (member "--search-paths" args)
 632             (when (y-or-n-p
 633                    (format "'%s' command will spawn an external process.
 634 Do you really want to execute this command in Geiser REPL? "
 635                            (guix-command-string args)))
 636               (message "May \"M-x shell-mode\" be with you!")
 637               t))
 638     (guix-run-command-in-repl args)))
 639
 640 (defun guix-run-pull-command-in-repl (args)
 641   "Run 'guix ARGS ...' pull command in Guix REPL.
 642 Perform pull-specific actions after operation, see
 643 `guix-after-pull-hook' and `guix-update-after-pull'."
 644   (guix-eval-in-repl
 645    (apply #'guix-make-guile-expression 'guix-command args)
 646    nil 'pull))
 647
 648 (defun guix-run-view-build-log (args)
 649   "Add --log-file to ARGS, run 'guix ARGS ...' build command, and
 650 open the log file(s)."
 651   (let* ((args (if (member "--log-file" args)
 652                    args
 653                  (apply #'list (car args) "--log-file" (cdr args))))
 654          (output (guix-command-output args))
 655          (files  (split-string output "\n" t)))
 656     (dolist (file files)
 657       (guix-find-file-or-url file)
 658       (guix-build-log-mode))))
 659
 660 (defun guix-run-view-graph (args)
 661   "Run 'guix ARGS ...' graph command, make the image and open it."
 662   (let* ((graph-file (guix-dot-file-name))
 663          (dot-args   (guix-dot-arguments graph-file)))
 664     (if (guix-eval-read (guix-make-guile-expression
 665                          'pipe-guix-output args dot-args))
 666         (guix-find-file graph-file)
 667       (error "Couldn't create a graph"))))
 668
 669 (defun guix-run-view-size-map (args)
 670   "Run 'guix ARGS ...' size command, and open the map file."
 671   (let* ((wished-map-file
 672           (cl-some (lambda (arg)
 673                      (and (string-match "--map-file=\\(.+\\)" arg)
 674                           (match-string 1 arg)))
 675                    args))
 676          (map-file (or wished-map-file (guix-png-file-name)))
 677          (args (if wished-map-file
 678                    args
 679                  (apply #'list
 680                         (car args)
 681                         (concat "--map-file=" map-file)
 682                         (cdr args)))))
 683     (guix-command-output args)
 684     (guix-find-file map-file)))
 685
 686 \f
 687 ;;; Generating popups, actions, etc.
 688
 689 (defmacro guix-command-define-popup-action (name &optional commands)
 690   "Define NAME function to generate (if needed) and run popup for COMMANDS."
 691   (declare (indent 1) (debug t))
 692   (let* ((popup-fun (guix-command-symbol `(,@commands "popup")))
 693          (doc (format "Call `%s' (generate it if needed)."
 694                       popup-fun)))
 695     `(defun ,name (&optional arg)
 696        ,doc
 697        (interactive "P")
 698        (unless (fboundp ',popup-fun)
 699          (guix-command-generate-popup ',popup-fun ',commands))
 700        (,popup-fun arg))))
 701
 702 (defmacro guix-command-define-execute-action (name executor
 703                                                    &optional commands)
 704   "Define NAME function to execute the current action for guix COMMANDS.
 705 EXECUTOR function is called with the current command line arguments."
 706   (declare (indent 1) (debug t))
 707   (let* ((arguments-fun (guix-command-symbol `(,@commands "arguments")))
 708          (doc (format "Call `%s' with the current popup arguments."
 709                       executor)))
 710     `(defun ,name (&rest args)
 711        ,doc
 712        (interactive (,arguments-fun))
 713        (,executor (append ',commands
 714                           (guix-command-post-process-args
 715                            ',commands args))))))
 716
 717 (defun guix-command-generate-popup-actions (actions &optional commands)
 718   "Generate 'popup' commands from ACTIONS arguments for guix COMMANDS."
 719   (dolist (action actions)
 720     (let ((fun (guix-command-argument-fun action)))
 721       (unless (fboundp fun)
 722         (eval `(guix-command-define-popup-action ,fun
 723                  ,(append commands
 724                           (list (guix-command-argument-name action)))))))))
 725
 726 (defun guix-command-generate-execute-actions (actions &optional commands)
 727   "Generate 'execute' commands from ACTIONS arguments for guix COMMANDS."
 728   (dolist (action actions)
 729     (let ((fun (guix-command-argument-fun action)))
 730       (unless (fboundp fun)
 731         (eval `(guix-command-define-execute-action ,fun
 732                  ,(guix-command-executor
 733                    commands (guix-command-argument-name action))
 734                  ,commands))))))
 735
 736 (defun guix-command-generate-popup (name &optional commands)
 737   "Define NAME popup with 'guix COMMANDS ...' interface."
 738   (let* ((command  (car commands))
 739          (man-page (concat "guix" (and command (concat "-" command))))
 740          (doc      (format "Popup window for '%s' command."
 741                            (guix-concat-strings (cons "guix" commands)
 742                                                 " ")))
 743          (args     (guix-command-arguments commands))
 744          (switches (guix-command-sort-arguments
 745                     (guix-command-switches args)))
 746          (options  (guix-command-sort-arguments
 747                     (guix-command-options args)))
 748          (popup-actions (guix-command-sort-arguments
 749                          (guix-command-actions args)))
 750          (execute-actions (unless popup-actions
 751                             (guix-command-execute-arguments commands)))
 752          (actions (or popup-actions execute-actions)))
 753     (if popup-actions
 754         (guix-command-generate-popup-actions popup-actions commands)
 755       (guix-command-generate-execute-actions execute-actions commands))
 756     (eval
 757      `(guix-define-popup ,name
 758         ,doc
 759         'guix-commands
 760         :man-page ,man-page
 761         :switches ',(mapcar #'guix-command-switch->popup-switch switches)
 762         :options  ',(mapcar #'guix-command-option->popup-option options)
 763         :actions  ',(mapcar #'guix-command-action->popup-action actions)
 764         :max-action-columns 4))))
 765
 766 ;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t)
 767 (guix-command-define-popup-action guix)
 768
 769 (defalias 'guix-edit-action #'guix-edit)
 770
 771 \f
 772 (defvar guix-command-font-lock-keywords
 773   (eval-when-compile
 774     `((,(rx "("
 775             (group "guix-command-define-"
 776                    (or "popup-action"
 777                        "execute-action"
 778                        "argument-improver"))
 779             symbol-end
 780             (zero-or-more blank)
 781             (zero-or-one
 782              (group (one-or-more (or (syntax word) (syntax symbol))))))
 783        (1 font-lock-keyword-face)
 784        (2 font-lock-function-name-face nil t)))))
 785
 786 (font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords)
 787
 788 (provide 'guix-command)
 789
 790 ;;; guix-command.el ends here