diff options
Diffstat (limited to 'emacs/guix-command.el')
| -rw-r--r-- | emacs/guix-command.el | 649 |
1 files changed, 649 insertions, 0 deletions
diff --git a/emacs/guix-command.el b/emacs/guix-command.el new file mode 100644 index 0000000000..97a88726df --- /dev/null +++ b/emacs/guix-command.el @@ -0,0 +1,649 @@ +;;; 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) + +(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))) + +(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) + (("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." + (or (guix-any (lambda (improver) + (funcall improver argument)) + improvers) + 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 + nil + "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") + ("repl" . guix-run-pull-command-in-repl))) + "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)) + + +;;; 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) + + +(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 |