guix-devel/emacs/guix-command.el

;;; 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)

(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