;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- ;; Copyright © 2015 Alex Kost ;; 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 . ;;; 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) (require 'guix-guile) (require 'guix-external) (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-argument '(("cran" :char ?r))) (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") guix-command-improve-import-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 (cl-some (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 `((("build") ,(guix-command-make-argument :name "log" :char ?l :doc "View build log")) (("graph") ,(guix-command-make-argument :name "view" :char ?v :doc "View graph")) (("size") ,(guix-command-make-argument :name "view" :char ?v :doc "View map"))) "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)) (("build") ("log" . guix-run-view-build-log)) (("graph") ("view" . guix-run-view-graph)) (("size") ("view" . guix-run-view-size-map))) "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)) (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)))) (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")))) (defun guix-run-view-size-map (args) "Run 'guix ARGS ...' size command, and open the map file." (let* ((wished-map-file (cl-some (lambda (arg) (and (string-match "--map-file=\\(.+\\)" arg) (match-string 1 arg))) args)) (map-file (or wished-map-file (guix-png-file-name))) (args (if wished-map-file args (apply #'list (car args) (concat "--map-file=" map-file) (cdr args))))) (guix-command-output args) (guix-find-file map-file))) ;;; 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) (defalias 'guix-edit-action #'guix-edit) (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