2015-08-14 09:47:10 +02:00
|
|
|
|
;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*-
|
|
|
|
|
|
|
|
|
|
;; Copyright © 2015 Alex Kost <alezost@gmail.com>
|
|
|
|
|
|
|
|
|
|
;; This file is part of GNU Guix.
|
|
|
|
|
|
|
|
|
|
;; GNU Guix is free software; you can redistribute it and/or modify
|
|
|
|
|
;; it under the terms of the GNU General Public License as published by
|
|
|
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
|
|
|
;; (at your option) any later version.
|
|
|
|
|
|
|
|
|
|
;; GNU Guix is distributed in the hope that it will be useful,
|
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
|
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
|
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
|
|
|
|
|
;; This file provides a magit-like popup interface for running guix
|
|
|
|
|
;; commands in Guix REPL. The entry point is "M-x guix". When it is
|
|
|
|
|
;; called the first time, "guix --help" output is parsed and
|
|
|
|
|
;; `guix-COMMAND-action' functions are generated for each available guix
|
|
|
|
|
;; COMMAND. Then a window with these commands is popped up. When a
|
|
|
|
|
;; particular COMMAND is called, "guix COMMAND --help" output is parsed,
|
|
|
|
|
;; and a user get a new popup window with available options for this
|
|
|
|
|
;; command and so on.
|
|
|
|
|
|
|
|
|
|
;; To avoid hard-coding all guix options, actions, etc., as much data is
|
|
|
|
|
;; taken from "guix ... --help" outputs as possible. But this data is
|
|
|
|
|
;; still incomplete: not all long options have short analogs, also
|
|
|
|
|
;; special readers should be used for some options (for example, to
|
|
|
|
|
;; complete package names while prompting for a package). So after
|
|
|
|
|
;; parsing --help output, the arguments are "improved". All arguments
|
|
|
|
|
;; (switches, options and actions) are `guix-command-argument'
|
|
|
|
|
;; structures.
|
|
|
|
|
|
|
|
|
|
;; Only "M-x guix" command is available after this file is loaded. The
|
|
|
|
|
;; rest commands/actions/popups are generated on the fly only when they
|
|
|
|
|
;; are needed (that's why there is a couple of `eval'-s in this file).
|
|
|
|
|
|
|
|
|
|
;; COMMANDS argument is used by many functions in this file. It means a
|
|
|
|
|
;; list of guix commands without "guix" itself, e.g.: ("build"),
|
|
|
|
|
;; ("import" "gnu"). The empty list stands for the plain "guix" without
|
|
|
|
|
;; subcommands.
|
|
|
|
|
|
|
|
|
|
;; All actions in popup windows are divided into 2 groups:
|
|
|
|
|
;;
|
|
|
|
|
;; - 'Popup' actions - used to pop up another window. For example, every
|
|
|
|
|
;; action in the 'guix' or 'guix import' window is a popup action. They
|
|
|
|
|
;; are defined by `guix-command-define-popup-action' macro.
|
|
|
|
|
;;
|
|
|
|
|
;; - 'Execute' actions - used to do something with the command line (to
|
|
|
|
|
;; run a command in Guix REPL or to copy it into kill-ring) constructed
|
|
|
|
|
;; with the current popup. They are defined by
|
|
|
|
|
;; `guix-command-define-execute-action' macro.
|
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
(require 'cl-lib)
|
|
|
|
|
(require 'guix-popup)
|
|
|
|
|
(require 'guix-utils)
|
|
|
|
|
(require 'guix-help-vars)
|
|
|
|
|
(require 'guix-read)
|
|
|
|
|
(require 'guix-base)
|
2015-08-30 17:52:30 +02:00
|
|
|
|
(require 'guix-external)
|
2015-08-14 09:47:10 +02:00
|
|
|
|
|
|
|
|
|
(defgroup guix-commands nil
|
|
|
|
|
"Settings for guix popup windows."
|
|
|
|
|
:group 'guix)
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-complex-with-shared-arguments
|
|
|
|
|
'("system")
|
|
|
|
|
"List of guix commands which have subcommands with shared options.
|
|
|
|
|
I.e., 'guix foo --help' is the same as 'guix foo bar --help'.")
|
|
|
|
|
|
|
|
|
|
(defun guix-command-action-name (&optional commands &rest name-parts)
|
|
|
|
|
"Return name of action function for guix COMMANDS."
|
|
|
|
|
(guix-command-symbol (append commands name-parts (list "action"))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Command arguments
|
|
|
|
|
|
|
|
|
|
(cl-defstruct (guix-command-argument
|
|
|
|
|
(:constructor guix-command-make-argument)
|
|
|
|
|
(:copier guix-command-copy-argument))
|
|
|
|
|
name char doc fun switch? option? action?)
|
|
|
|
|
|
|
|
|
|
(cl-defun guix-command-modify-argument
|
|
|
|
|
(argument &key
|
|
|
|
|
(name nil name-bound?)
|
|
|
|
|
(char nil char-bound?)
|
|
|
|
|
(doc nil doc-bound?)
|
|
|
|
|
(fun nil fun-bound?)
|
|
|
|
|
(switch? nil switch?-bound?)
|
|
|
|
|
(option? nil option?-bound?)
|
|
|
|
|
(action? nil action?-bound?))
|
|
|
|
|
"Return a modified version of ARGUMENT."
|
|
|
|
|
(declare (indent 1))
|
|
|
|
|
(let ((copy (guix-command-copy-argument argument)))
|
|
|
|
|
(and name-bound? (setf (guix-command-argument-name copy) name))
|
|
|
|
|
(and char-bound? (setf (guix-command-argument-char copy) char))
|
|
|
|
|
(and doc-bound? (setf (guix-command-argument-doc copy) doc))
|
|
|
|
|
(and fun-bound? (setf (guix-command-argument-fun copy) fun))
|
|
|
|
|
(and switch?-bound? (setf (guix-command-argument-switch? copy) switch?))
|
|
|
|
|
(and option?-bound? (setf (guix-command-argument-option? copy) option?))
|
|
|
|
|
(and action?-bound? (setf (guix-command-argument-action? copy) action?))
|
|
|
|
|
copy))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-modify-argument-from-alist (argument alist)
|
|
|
|
|
"Return a modified version of ARGUMENT or nil if it wasn't modified.
|
|
|
|
|
Each assoc from ALIST have a form (NAME . PLIST). NAME is an
|
|
|
|
|
argument name. PLIST is a property list of argument parameters
|
|
|
|
|
to be modified."
|
|
|
|
|
(let* ((name (guix-command-argument-name argument))
|
|
|
|
|
(plist (guix-assoc-value alist name)))
|
|
|
|
|
(when plist
|
|
|
|
|
(apply #'guix-command-modify-argument
|
|
|
|
|
argument plist))))
|
|
|
|
|
|
|
|
|
|
(defmacro guix-command-define-argument-improver (name alist)
|
|
|
|
|
"Define NAME variable and function to modify an argument from ALIST."
|
|
|
|
|
(declare (indent 1))
|
|
|
|
|
`(progn
|
|
|
|
|
(defvar ,name ,alist)
|
|
|
|
|
(defun ,name (argument)
|
|
|
|
|
(guix-command-modify-argument-from-alist argument ,name))))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-action-argument
|
|
|
|
|
'(("graph" :char ?G)
|
|
|
|
|
("environment" :char ?E)
|
|
|
|
|
("publish" :char ?u)
|
|
|
|
|
("pull" :char ?P)
|
|
|
|
|
("size" :char ?z)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-common-argument
|
|
|
|
|
'(("--help" :switch? nil)
|
|
|
|
|
("--version" :switch? nil)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-target-argument
|
|
|
|
|
'(("--target" :char ?T)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-system-type-argument
|
|
|
|
|
'(("--system" :fun guix-read-system-type)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-load-path-argument
|
|
|
|
|
'(("--load-path" :fun read-directory-name)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-search-paths-argument
|
|
|
|
|
'(("--search-paths" :char ?P)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-substitute-urls-argument
|
|
|
|
|
'(("--substitute-urls" :char ?U)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-hash-argument
|
|
|
|
|
'(("--format" :fun guix-read-hash-format)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-key-policy-argument
|
|
|
|
|
'(("--key-download" :fun guix-read-key-policy)))
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-improve-common-build-argument
|
|
|
|
|
'(("--no-substitutes" :char ?s)
|
|
|
|
|
("--no-build-hook" :char ?h)
|
|
|
|
|
("--max-silent-time" :char ?x)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-improve-common-build-argument (argument)
|
|
|
|
|
(guix-command-modify-argument-from-alist
|
|
|
|
|
argument
|
|
|
|
|
(append guix-command-improve-load-path-argument
|
|
|
|
|
guix-command-improve-substitute-urls-argument
|
|
|
|
|
guix-command-improve-common-build-argument)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-archive-argument
|
|
|
|
|
'(("--generate-key" :char ?k)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-build-argument
|
|
|
|
|
'(("--no-grafts" :char ?g)
|
|
|
|
|
("--root" :fun guix-read-file-name)
|
|
|
|
|
("--sources" :char ?S :fun guix-read-source-type :switch? nil)
|
|
|
|
|
("--with-source" :fun guix-read-file-name)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-environment-argument
|
|
|
|
|
'(("--exec" :fun read-shell-command)
|
|
|
|
|
("--load" :fun guix-read-file-name)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-gc-argument
|
|
|
|
|
'(("--list-dead" :char ?D)
|
|
|
|
|
("--list-live" :char ?L)
|
|
|
|
|
("--referrers" :char ?f)
|
|
|
|
|
("--verify" :fun guix-read-verify-options-string)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-graph-argument
|
|
|
|
|
'(("--type" :fun guix-read-graph-type)))
|
|
|
|
|
|
2015-09-01 12:10:41 +02:00
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-import-argument
|
|
|
|
|
'(("cran" :char ?r)))
|
|
|
|
|
|
2015-08-14 09:47:10 +02:00
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-import-elpa-argument
|
|
|
|
|
'(("--archive" :fun guix-read-elpa-archive)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-lint-argument
|
|
|
|
|
'(("--checkers" :fun guix-read-lint-checker-names-string)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-package-argument
|
|
|
|
|
;; Unlike all other options, --install/--remove do not have a form
|
|
|
|
|
;; '--install=foo,bar' but '--install foo bar' instead, so we need
|
|
|
|
|
;; some tweaks.
|
|
|
|
|
'(("--install"
|
|
|
|
|
:name "--install " :fun guix-read-package-names-string
|
|
|
|
|
:switch? nil :option? t)
|
|
|
|
|
("--remove"
|
|
|
|
|
:name "--remove " :fun guix-read-package-names-string
|
|
|
|
|
:switch? nil :option? t)
|
|
|
|
|
("--install-from-file" :fun guix-read-file-name)
|
|
|
|
|
("--manifest" :fun guix-read-file-name)
|
|
|
|
|
("--do-not-upgrade" :char ?U)
|
|
|
|
|
("--roll-back" :char ?R)
|
|
|
|
|
("--show" :char ?w :fun guix-read-package-name)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-refresh-argument
|
|
|
|
|
'(("--select" :fun guix-read-refresh-subset)
|
|
|
|
|
("--key-server" :char ?S)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-size-argument
|
|
|
|
|
'(("--map-file" :fun guix-read-file-name)))
|
|
|
|
|
|
|
|
|
|
(guix-command-define-argument-improver
|
|
|
|
|
guix-command-improve-system-argument
|
|
|
|
|
'(("vm-image" :char ?V)
|
|
|
|
|
("--on-error" :char ?E)
|
|
|
|
|
("--no-grub" :char ?g)
|
|
|
|
|
("--full-boot" :char ?b)))
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-argument-improvers
|
|
|
|
|
'((()
|
|
|
|
|
guix-command-improve-action-argument)
|
|
|
|
|
(("archive")
|
|
|
|
|
guix-command-improve-common-build-argument
|
|
|
|
|
guix-command-improve-target-argument
|
|
|
|
|
guix-command-improve-system-type-argument
|
|
|
|
|
guix-command-improve-archive-argument)
|
|
|
|
|
(("build")
|
|
|
|
|
guix-command-improve-common-build-argument
|
|
|
|
|
guix-command-improve-target-argument
|
|
|
|
|
guix-command-improve-system-type-argument
|
|
|
|
|
guix-command-improve-build-argument)
|
|
|
|
|
(("download")
|
|
|
|
|
guix-command-improve-hash-argument)
|
|
|
|
|
(("hash")
|
|
|
|
|
guix-command-improve-hash-argument)
|
|
|
|
|
(("environment")
|
|
|
|
|
guix-command-improve-common-build-argument
|
|
|
|
|
guix-command-improve-search-paths-argument
|
|
|
|
|
guix-command-improve-system-type-argument
|
|
|
|
|
guix-command-improve-environment-argument)
|
|
|
|
|
(("gc")
|
|
|
|
|
guix-command-improve-gc-argument)
|
|
|
|
|
(("graph")
|
|
|
|
|
guix-command-improve-graph-argument)
|
2015-09-01 12:10:41 +02:00
|
|
|
|
(("import")
|
|
|
|
|
guix-command-improve-import-argument)
|
2015-08-14 09:47:10 +02:00
|
|
|
|
(("import" "gnu")
|
|
|
|
|
guix-command-improve-key-policy-argument)
|
|
|
|
|
(("import" "elpa")
|
|
|
|
|
guix-command-improve-import-elpa-argument)
|
|
|
|
|
(("lint")
|
|
|
|
|
guix-command-improve-lint-argument)
|
|
|
|
|
(("package")
|
|
|
|
|
guix-command-improve-common-build-argument
|
|
|
|
|
guix-command-improve-search-paths-argument
|
|
|
|
|
guix-command-improve-package-argument)
|
|
|
|
|
(("refresh")
|
|
|
|
|
guix-command-improve-key-policy-argument
|
|
|
|
|
guix-command-improve-refresh-argument)
|
|
|
|
|
(("size")
|
|
|
|
|
guix-command-improve-system-type-argument
|
|
|
|
|
guix-command-improve-substitute-urls-argument
|
|
|
|
|
guix-command-improve-size-argument)
|
|
|
|
|
(("system")
|
|
|
|
|
guix-command-improve-common-build-argument
|
|
|
|
|
guix-command-improve-system-argument))
|
|
|
|
|
"Alist of guix commands and argument improvers for them.")
|
|
|
|
|
|
|
|
|
|
(defun guix-command-improve-argument (argument improvers)
|
|
|
|
|
"Return ARGUMENT modified with IMPROVERS."
|
2015-09-15 20:36:23 +02:00
|
|
|
|
(or (cl-some (lambda (improver)
|
|
|
|
|
(funcall improver argument))
|
|
|
|
|
improvers)
|
2015-08-14 09:47:10 +02:00
|
|
|
|
argument))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-improve-arguments (arguments commands)
|
|
|
|
|
"Return ARGUMENTS for 'guix COMMANDS ...' modified for popup interface."
|
|
|
|
|
(let ((improvers (cons 'guix-command-improve-common-argument
|
|
|
|
|
(guix-assoc-value guix-command-argument-improvers
|
|
|
|
|
commands))))
|
|
|
|
|
(mapcar (lambda (argument)
|
|
|
|
|
(guix-command-improve-argument argument improvers))
|
|
|
|
|
arguments)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-parse-arguments (&optional commands)
|
|
|
|
|
"Return a list of parsed 'guix COMMANDS ...' arguments."
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(insert (guix-help-string commands))
|
|
|
|
|
(let (args)
|
|
|
|
|
(guix-while-search guix-help-parse-option-regexp
|
|
|
|
|
(let* ((short (match-string-no-properties 1))
|
|
|
|
|
(name (match-string-no-properties 2))
|
|
|
|
|
(arg (match-string-no-properties 3))
|
|
|
|
|
(doc (match-string-no-properties 4))
|
|
|
|
|
(char (if short
|
|
|
|
|
(elt short 1) ; short option letter
|
|
|
|
|
(elt name 2))) ; first letter of the long option
|
|
|
|
|
;; If "--foo=bar" or "--foo[=bar]" then it is 'option'.
|
|
|
|
|
(option? (not (string= "" arg)))
|
|
|
|
|
;; If "--foo" or "--foo[=bar]" then it is 'switch'.
|
|
|
|
|
(switch? (or (string= "" arg)
|
|
|
|
|
(eq ?\[ (elt arg 0)))))
|
|
|
|
|
(push (guix-command-make-argument
|
|
|
|
|
:name name
|
|
|
|
|
:char char
|
|
|
|
|
:doc doc
|
|
|
|
|
:switch? switch?
|
|
|
|
|
:option? option?)
|
|
|
|
|
args)))
|
|
|
|
|
(guix-while-search guix-help-parse-command-regexp
|
|
|
|
|
(let* ((name (match-string-no-properties 1))
|
|
|
|
|
(char (elt name 0)))
|
|
|
|
|
(push (guix-command-make-argument
|
|
|
|
|
:name name
|
|
|
|
|
:char char
|
|
|
|
|
:fun (guix-command-action-name commands name)
|
|
|
|
|
:action? t)
|
|
|
|
|
args)))
|
|
|
|
|
args)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-rest-argument (&optional commands)
|
|
|
|
|
"Return '--' argument for COMMANDS."
|
|
|
|
|
(cl-flet ((argument (&rest args)
|
|
|
|
|
(apply #'guix-command-make-argument
|
|
|
|
|
:name "-- " :char ?= :option? t args)))
|
|
|
|
|
(let ((command (car commands)))
|
|
|
|
|
(cond
|
|
|
|
|
((member command '("archive" "build" "graph" "edit"
|
|
|
|
|
"environment" "lint" "refresh"))
|
|
|
|
|
(argument :doc "Packages" :fun 'guix-read-package-names-string))
|
|
|
|
|
((string= command "download")
|
|
|
|
|
(argument :doc "URL"))
|
|
|
|
|
((string= command "gc")
|
|
|
|
|
(argument :doc "Paths" :fun 'guix-read-file-name))
|
|
|
|
|
((member command '("hash" "system"))
|
|
|
|
|
(argument :doc "File" :fun 'guix-read-file-name))
|
|
|
|
|
((string= command "size")
|
|
|
|
|
(argument :doc "Package" :fun 'guix-read-package-name))
|
|
|
|
|
((equal commands '("import" "nix"))
|
|
|
|
|
(argument :doc "Nixpkgs Attribute"))
|
|
|
|
|
;; Other 'guix import' subcommands, but not 'import' itself.
|
|
|
|
|
((and (cdr commands)
|
|
|
|
|
(string= command "import"))
|
|
|
|
|
(argument :doc "Package name"))))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-additional-arguments (&optional commands)
|
|
|
|
|
"Return additional arguments for COMMANDS."
|
|
|
|
|
(let ((rest-arg (guix-command-rest-argument commands)))
|
|
|
|
|
(and rest-arg (list rest-arg))))
|
|
|
|
|
|
|
|
|
|
;; Ideally only `guix-command-arguments' function should exist with the
|
|
|
|
|
;; contents of `guix-command-all-arguments', but we need to make a
|
|
|
|
|
;; special case for `guix-command-complex-with-shared-arguments' commands.
|
|
|
|
|
|
|
|
|
|
(defun guix-command-all-arguments (&optional commands)
|
|
|
|
|
"Return list of all arguments for 'guix COMMANDS ...'."
|
|
|
|
|
(let ((parsed (guix-command-parse-arguments commands)))
|
|
|
|
|
(append (guix-command-improve-arguments parsed commands)
|
|
|
|
|
(guix-command-additional-arguments commands))))
|
|
|
|
|
|
|
|
|
|
(guix-memoized-defalias guix-command-all-arguments-memoize
|
|
|
|
|
guix-command-all-arguments)
|
|
|
|
|
|
|
|
|
|
(defun guix-command-arguments (&optional commands)
|
|
|
|
|
"Return list of arguments for 'guix COMMANDS ...'."
|
|
|
|
|
(let ((command (car commands)))
|
|
|
|
|
(if (member command
|
|
|
|
|
guix-command-complex-with-shared-arguments)
|
|
|
|
|
;; Take actions only for 'guix system', and switches+options for
|
|
|
|
|
;; 'guix system foo'.
|
|
|
|
|
(funcall (if (null (cdr commands))
|
|
|
|
|
#'cl-remove-if-not
|
|
|
|
|
#'cl-remove-if)
|
|
|
|
|
#'guix-command-argument-action?
|
|
|
|
|
(guix-command-all-arguments-memoize (list command)))
|
|
|
|
|
(guix-command-all-arguments commands))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-switch->popup-switch (switch)
|
|
|
|
|
"Return popup switch from command SWITCH argument."
|
|
|
|
|
(list (guix-command-argument-char switch)
|
|
|
|
|
(or (guix-command-argument-doc switch)
|
|
|
|
|
"Unknown")
|
|
|
|
|
(guix-command-argument-name switch)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-option->popup-option (option)
|
|
|
|
|
"Return popup option from command OPTION argument."
|
|
|
|
|
(list (guix-command-argument-char option)
|
|
|
|
|
(or (guix-command-argument-doc option)
|
|
|
|
|
"Unknown")
|
|
|
|
|
(let ((name (guix-command-argument-name option)))
|
|
|
|
|
(if (string-match-p " \\'" name) ; ends with space
|
|
|
|
|
name
|
|
|
|
|
(concat name "=")))
|
|
|
|
|
(or (guix-command-argument-fun option)
|
|
|
|
|
'read-from-minibuffer)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-action->popup-action (action)
|
|
|
|
|
"Return popup action from command ACTION argument."
|
|
|
|
|
(list (guix-command-argument-char action)
|
|
|
|
|
(or (guix-command-argument-doc action)
|
|
|
|
|
(guix-command-argument-name action)
|
|
|
|
|
"Unknown")
|
|
|
|
|
(guix-command-argument-fun action)))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-sort-arguments (arguments)
|
|
|
|
|
"Sort ARGUMENTS by name in alphabetical order."
|
|
|
|
|
(sort arguments
|
|
|
|
|
(lambda (a1 a2)
|
|
|
|
|
(let ((name1 (guix-command-argument-name a1))
|
|
|
|
|
(name2 (guix-command-argument-name a2)))
|
|
|
|
|
(cond ((null name1) nil)
|
|
|
|
|
((null name2) t)
|
|
|
|
|
(t (string< name1 name2)))))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-switches (arguments)
|
|
|
|
|
"Return switches from ARGUMENTS."
|
|
|
|
|
(cl-remove-if-not #'guix-command-argument-switch? arguments))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-options (arguments)
|
|
|
|
|
"Return options from ARGUMENTS."
|
|
|
|
|
(cl-remove-if-not #'guix-command-argument-option? arguments))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-actions (arguments)
|
|
|
|
|
"Return actions from ARGUMENTS."
|
|
|
|
|
(cl-remove-if-not #'guix-command-argument-action? arguments))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-post-process-args (args)
|
|
|
|
|
"Adjust appropriately command line ARGS returned from popup command."
|
|
|
|
|
;; XXX We need to split "--install foo bar" and similar strings into
|
|
|
|
|
;; lists of strings. But some commands (e.g., 'guix hash') accept a
|
|
|
|
|
;; file name as the 'rest' argument, and as file names may contain
|
|
|
|
|
;; spaces, splitting by spaces will break such names. For example, the
|
|
|
|
|
;; following argument: "-- /tmp/file with spaces" will be transformed
|
|
|
|
|
;; into the following list: ("--" "/tmp/file" "with" "spaces") instead
|
|
|
|
|
;; of the wished ("--" "/tmp/file with spaces").
|
|
|
|
|
(let* (rest
|
|
|
|
|
(rx (rx string-start
|
|
|
|
|
(or "-- " "--install " "--remove ")))
|
|
|
|
|
(args (mapcar (lambda (arg)
|
|
|
|
|
(if (string-match-p rx arg)
|
|
|
|
|
(progn (push (split-string arg) rest)
|
|
|
|
|
nil)
|
|
|
|
|
arg))
|
|
|
|
|
args)))
|
|
|
|
|
(if rest
|
|
|
|
|
(apply #'append (delq nil args) rest)
|
|
|
|
|
args)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; 'Execute' actions
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-default-execute-arguments
|
|
|
|
|
(list
|
|
|
|
|
(guix-command-make-argument
|
|
|
|
|
:name "repl" :char ?r :doc "Run in Guix REPL")
|
|
|
|
|
(guix-command-make-argument
|
|
|
|
|
:name "shell" :char ?s :doc "Run in shell")
|
|
|
|
|
(guix-command-make-argument
|
|
|
|
|
:name "copy" :char ?c :doc "Copy command line"))
|
|
|
|
|
"List of default 'execute' action arguments.")
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-additional-execute-arguments
|
2015-09-13 20:30:05 +02:00
|
|
|
|
`((("build")
|
|
|
|
|
,(guix-command-make-argument
|
|
|
|
|
:name "log" :char ?l :doc "View build log"))
|
|
|
|
|
(("graph")
|
2015-08-30 17:52:30 +02:00
|
|
|
|
,(guix-command-make-argument
|
|
|
|
|
:name "view" :char ?v :doc "View graph")))
|
2015-08-14 09:47:10 +02:00
|
|
|
|
"Alist of guix commands and additional 'execute' action arguments.")
|
|
|
|
|
|
|
|
|
|
(defun guix-command-execute-arguments (commands)
|
|
|
|
|
"Return a list of 'execute' action arguments for COMMANDS."
|
|
|
|
|
(mapcar (lambda (arg)
|
|
|
|
|
(guix-command-modify-argument arg
|
|
|
|
|
:action? t
|
|
|
|
|
:fun (guix-command-action-name
|
|
|
|
|
commands (guix-command-argument-name arg))))
|
|
|
|
|
(append guix-command-default-execute-arguments
|
|
|
|
|
(guix-assoc-value
|
|
|
|
|
guix-command-additional-execute-arguments commands))))
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-special-executors
|
|
|
|
|
'((("environment")
|
|
|
|
|
("repl" . guix-run-environment-command-in-repl))
|
|
|
|
|
(("pull")
|
2015-08-30 17:52:30 +02:00
|
|
|
|
("repl" . guix-run-pull-command-in-repl))
|
2015-09-13 20:30:05 +02:00
|
|
|
|
(("build")
|
|
|
|
|
("log" . guix-run-view-build-log))
|
2015-08-30 17:52:30 +02:00
|
|
|
|
(("graph")
|
|
|
|
|
("view" . guix-run-view-graph)))
|
2015-08-14 09:47:10 +02:00
|
|
|
|
"Alist of guix commands and alists of special executers for them.
|
|
|
|
|
See also `guix-command-default-executors'.")
|
|
|
|
|
|
|
|
|
|
(defvar guix-command-default-executors
|
|
|
|
|
'(("repl" . guix-run-command-in-repl)
|
|
|
|
|
("shell" . guix-run-command-in-shell)
|
|
|
|
|
("copy" . guix-copy-command-as-kill))
|
|
|
|
|
"Alist of default executers for action names.")
|
|
|
|
|
|
|
|
|
|
(defun guix-command-executor (commands name)
|
|
|
|
|
"Return function to run command line arguments for guix COMMANDS."
|
|
|
|
|
(or (guix-assoc-value guix-command-special-executors commands name)
|
|
|
|
|
(guix-assoc-value guix-command-default-executors name)))
|
|
|
|
|
|
|
|
|
|
(defun guix-run-environment-command-in-repl (args)
|
|
|
|
|
"Run 'guix ARGS ...' environment command in Guix REPL."
|
|
|
|
|
;; As 'guix environment' usually tries to run another process, it may
|
|
|
|
|
;; be fun but not wise to run this command in Geiser REPL.
|
|
|
|
|
(when (or (member "--dry-run" args)
|
|
|
|
|
(member "--search-paths" args)
|
|
|
|
|
(when (y-or-n-p
|
|
|
|
|
(format "'%s' command will spawn an external process.
|
|
|
|
|
Do you really want to execute this command in Geiser REPL? "
|
|
|
|
|
(guix-command-string args)))
|
|
|
|
|
(message "May \"M-x shell-mode\" be with you!")
|
|
|
|
|
t))
|
|
|
|
|
(guix-run-command-in-repl args)))
|
|
|
|
|
|
|
|
|
|
(defun guix-run-pull-command-in-repl (args)
|
|
|
|
|
"Run 'guix ARGS ...' pull command in Guix REPL.
|
|
|
|
|
Perform pull-specific actions after operation, see
|
|
|
|
|
`guix-after-pull-hook' and `guix-update-after-pull'."
|
|
|
|
|
(guix-eval-in-repl
|
|
|
|
|
(apply #'guix-make-guile-expression 'guix-command args)
|
|
|
|
|
nil 'pull))
|
|
|
|
|
|
2015-09-13 20:30:05 +02:00
|
|
|
|
(defun guix-run-view-build-log (args)
|
|
|
|
|
"Add --log-file to ARGS, run 'guix ARGS ...' build command, and
|
|
|
|
|
open the log file(s)."
|
|
|
|
|
(let* ((args (if (member "--log-file" args)
|
|
|
|
|
args
|
|
|
|
|
(apply #'list (car args) "--log-file" (cdr args))))
|
|
|
|
|
(output (guix-command-output args))
|
|
|
|
|
(files (split-string output "\n" t)))
|
|
|
|
|
(dolist (file files)
|
|
|
|
|
(guix-find-file-or-url file)
|
|
|
|
|
(guix-build-log-mode))))
|
|
|
|
|
|
2015-08-30 17:52:30 +02:00
|
|
|
|
(defun guix-run-view-graph (args)
|
|
|
|
|
"Run 'guix ARGS ...' graph command, make the image and open it."
|
|
|
|
|
(let* ((graph-file (guix-dot-file-name))
|
|
|
|
|
(dot-args (guix-dot-arguments graph-file)))
|
|
|
|
|
(if (guix-eval-read (guix-make-guile-expression
|
|
|
|
|
'pipe-guix-output args dot-args))
|
|
|
|
|
(guix-find-file graph-file)
|
|
|
|
|
(error "Couldn't create a graph"))))
|
|
|
|
|
|
2015-08-14 09:47:10 +02:00
|
|
|
|
|
|
|
|
|
;;; Generating popups, actions, etc.
|
|
|
|
|
|
|
|
|
|
(defmacro guix-command-define-popup-action (name &optional commands)
|
|
|
|
|
"Define NAME function to generate (if needed) and run popup for COMMANDS."
|
|
|
|
|
(declare (indent 1) (debug t))
|
|
|
|
|
(let* ((popup-fun (guix-command-symbol `(,@commands "popup")))
|
|
|
|
|
(doc (format "Call `%s' (generate it if needed)."
|
|
|
|
|
popup-fun)))
|
|
|
|
|
`(defun ,name (&optional arg)
|
|
|
|
|
,doc
|
|
|
|
|
(interactive "P")
|
|
|
|
|
(unless (fboundp ',popup-fun)
|
|
|
|
|
(guix-command-generate-popup ',popup-fun ',commands))
|
|
|
|
|
(,popup-fun arg))))
|
|
|
|
|
|
|
|
|
|
(defmacro guix-command-define-execute-action (name executor
|
|
|
|
|
&optional commands)
|
|
|
|
|
"Define NAME function to execute the current action for guix COMMANDS.
|
|
|
|
|
EXECUTOR function is called with the current command line arguments."
|
|
|
|
|
(declare (indent 1) (debug t))
|
|
|
|
|
(let* ((arguments-fun (guix-command-symbol `(,@commands "arguments")))
|
|
|
|
|
(doc (format "Call `%s' with the current popup arguments."
|
|
|
|
|
executor)))
|
|
|
|
|
`(defun ,name (&rest args)
|
|
|
|
|
,doc
|
|
|
|
|
(interactive (,arguments-fun))
|
|
|
|
|
(,executor (append ',commands
|
|
|
|
|
(guix-command-post-process-args args))))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-generate-popup-actions (actions &optional commands)
|
|
|
|
|
"Generate 'popup' commands from ACTIONS arguments for guix COMMANDS."
|
|
|
|
|
(dolist (action actions)
|
|
|
|
|
(let ((fun (guix-command-argument-fun action)))
|
|
|
|
|
(unless (fboundp fun)
|
|
|
|
|
(eval `(guix-command-define-popup-action ,fun
|
|
|
|
|
,(append commands
|
|
|
|
|
(list (guix-command-argument-name action)))))))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-generate-execute-actions (actions &optional commands)
|
|
|
|
|
"Generate 'execute' commands from ACTIONS arguments for guix COMMANDS."
|
|
|
|
|
(dolist (action actions)
|
|
|
|
|
(let ((fun (guix-command-argument-fun action)))
|
|
|
|
|
(unless (fboundp fun)
|
|
|
|
|
(eval `(guix-command-define-execute-action ,fun
|
|
|
|
|
,(guix-command-executor
|
|
|
|
|
commands (guix-command-argument-name action))
|
|
|
|
|
,commands))))))
|
|
|
|
|
|
|
|
|
|
(defun guix-command-generate-popup (name &optional commands)
|
|
|
|
|
"Define NAME popup with 'guix COMMANDS ...' interface."
|
|
|
|
|
(let* ((command (car commands))
|
|
|
|
|
(man-page (concat "guix" (and command (concat "-" command))))
|
|
|
|
|
(doc (format "Popup window for '%s' command."
|
|
|
|
|
(guix-concat-strings (cons "guix" commands)
|
|
|
|
|
" ")))
|
|
|
|
|
(args (guix-command-arguments commands))
|
|
|
|
|
(switches (guix-command-sort-arguments
|
|
|
|
|
(guix-command-switches args)))
|
|
|
|
|
(options (guix-command-sort-arguments
|
|
|
|
|
(guix-command-options args)))
|
|
|
|
|
(popup-actions (guix-command-sort-arguments
|
|
|
|
|
(guix-command-actions args)))
|
|
|
|
|
(execute-actions (unless popup-actions
|
|
|
|
|
(guix-command-execute-arguments commands)))
|
|
|
|
|
(actions (or popup-actions execute-actions)))
|
|
|
|
|
(if popup-actions
|
|
|
|
|
(guix-command-generate-popup-actions popup-actions commands)
|
|
|
|
|
(guix-command-generate-execute-actions execute-actions commands))
|
|
|
|
|
(eval
|
|
|
|
|
`(guix-define-popup ,name
|
|
|
|
|
,doc
|
|
|
|
|
'guix-commands
|
|
|
|
|
:man-page ,man-page
|
|
|
|
|
:switches ',(mapcar #'guix-command-switch->popup-switch switches)
|
|
|
|
|
:options ',(mapcar #'guix-command-option->popup-option options)
|
|
|
|
|
:actions ',(mapcar #'guix-command-action->popup-action actions)
|
|
|
|
|
:max-action-columns 4))))
|
|
|
|
|
|
|
|
|
|
;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t)
|
|
|
|
|
(guix-command-define-popup-action guix)
|
|
|
|
|
|
2015-08-17 11:05:05 +02:00
|
|
|
|
(defalias 'guix-edit-action #'guix-edit)
|
|
|
|
|
|
2015-08-14 09:47:10 +02:00
|
|
|
|
|
|
|
|
|
(defvar guix-command-font-lock-keywords
|
|
|
|
|
(eval-when-compile
|
|
|
|
|
`((,(rx "("
|
|
|
|
|
(group "guix-command-define-"
|
|
|
|
|
(or "popup-action"
|
|
|
|
|
"execute-action"
|
|
|
|
|
"argument-improver"))
|
|
|
|
|
symbol-end
|
|
|
|
|
(zero-or-more blank)
|
|
|
|
|
(zero-or-one
|
|
|
|
|
(group (one-or-more (or (syntax word) (syntax symbol))))))
|
|
|
|
|
(1 font-lock-keyword-face)
|
|
|
|
|
(2 font-lock-function-name-face nil t)))))
|
|
|
|
|
|
|
|
|
|
(font-lock-add-keywords 'emacs-lisp-mode guix-command-font-lock-keywords)
|
|
|
|
|
|
|
|
|
|
(provide 'guix-command)
|
|
|
|
|
|
|
|
|
|
;;; guix-command.el ends here
|