(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."
(guix-command-define-argument-improver
guix-command-improve-action-argument
- '(("graph" :char ?G)
+ '(("container" :char ?C)
+ ("graph" :char ?G)
("environment" :char ?E)
("publish" :char ?u)
("pull" :char ?P)
(guix-command-define-argument-improver
guix-command-improve-environment-argument
- '(("--exec" :fun read-shell-command)
+ '(("--ad-hoc"
+ :name "--ad-hoc " :fun guix-read-package-names-string
+ :switch? nil :option? t)
+ ("--expose" :char ?E)
+ ("--share" :char ?S)
("--load" :fun guix-read-file-name)))
(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-refresh-argument
'(("--select" :fun guix-read-refresh-subset)
+ ("--type" :fun guix-read-refresh-updater-names-string)
("--key-server" :char ?S)))
(guix-command-define-argument-improver
(guix-command-define-argument-improver
guix-command-improve-system-argument
- '(("vm-image" :char ?V)
+ '(("disk-image" :char ?D)
+ ("vm-image" :char ?V)
("--on-error" :char ?E)
("--no-grub" :char ?g)
("--full-boot" :char ?b)))
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")
(defun guix-command-improve-argument (argument improvers)
"Return ARGUMENT modified with IMPROVERS."
- (or (guix-any (lambda (improver)
- (funcall improver argument))
- improvers)
+ (or (cl-some (lambda (improver)
+ (funcall improver argument))
+ improvers)
argument))
(defun guix-command-improve-arguments (arguments commands)
:name "-- " :char ?= :option? t args)))
(let ((command (car commands)))
(cond
- ((member command '("archive" "build" "graph" "edit"
- "environment" "lint" "refresh"))
+ ((member command
+ '("archive" "build" "challenge" "edit"
+ "graph" "lint" "refresh"))
(argument :doc "Packages" :fun 'guix-read-package-names-string))
+ ((equal commands '("container" "exec"))
+ (argument :doc "PID Command [Args...]"))
((string= command "download")
(argument :doc "URL"))
+ ((string= command "environment")
+ (argument :doc "Command [Args...]" :fun 'read-shell-command))
((string= command "gc")
(argument :doc "Paths" :fun 'guix-read-file-name))
((member command '("hash" "system"))
(string= command "import"))
(argument :doc "Package name"))))))
+(defvar guix-command-additional-arguments
+ `((("environment")
+ ,(guix-command-make-argument
+ :name "++packages " :char ?p :option? t
+ :doc "build inputs of the specified packages"
+ :fun 'guix-read-package-names-string)))
+ "Alist of guix commands and additional arguments for them.
+These are 'fake' arguments that are not presented in 'guix' shell
+commands.")
+
(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))))
+ (append (guix-assoc-value guix-command-additional-arguments
+ 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
"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 ")))
+\f
+;;; Post processing popup arguments
+
+(defvar guix-command-post-processors
+ '(("environment"
+ guix-command-post-process-environment-packages
+ guix-command-post-process-environment-ad-hoc
+ guix-command-post-process-rest-multiple-leave)
+ ("hash"
+ guix-command-post-process-rest-single)
+ ("package"
+ guix-command-post-process-package-args)
+ ("system"
+ guix-command-post-process-rest-single))
+ "Alist of guix commands and functions for post-processing
+a list of arguments returned from popup interface.
+Each function is called on the returned arguments in turn.")
+
+(defvar guix-command-rest-arg-regexp
+ (rx string-start "-- " (group (+ any)))
+ "Regexp to match a string with the 'rest' arguments.")
+
+(defun guix-command-replace-args (args predicate modifier)
+ "Replace arguments matching PREDICATE from ARGS.
+Call MODIFIER on each argument matching PREDICATE and append the
+returned list of strings to the end of ARGS. Remove the original
+arguments."
+ (let* ((rest nil)
(args (mapcar (lambda (arg)
- (if (string-match-p rx arg)
- (progn (push (split-string arg) rest)
- nil)
+ (if (funcall predicate arg)
+ (progn
+ (push (funcall modifier arg) rest)
+ nil)
arg))
args)))
(if rest
(apply #'append (delq nil args) rest)
args)))
+(cl-defun guix-command-post-process-matching-args (args regexp
+ &key group split?)
+ "Modify arguments from ARGS matching REGEXP by moving them to
+the end of ARGS list. If SPLIT? is non-nil, split matching
+arguments into multiple subarguments."
+ (guix-command-replace-args
+ args
+ (lambda (arg)
+ (string-match regexp arg))
+ (lambda (arg)
+ (let ((val (match-string (or group 0) arg))
+ (fun (if split? #'split-string #'list)))
+ (funcall fun val)))))
+
+(defun guix-command-post-process-rest-single (args)
+ "Modify ARGS by moving '-- ARG' argument to the end of ARGS list."
+ (guix-command-post-process-matching-args
+ args guix-command-rest-arg-regexp
+ :group 1))
+
+(defun guix-command-post-process-rest-multiple (args)
+ "Modify ARGS by splitting '-- ARG ...' into multiple subarguments
+and moving them to the end of ARGS list.
+Remove '-- ' string."
+ (guix-command-post-process-matching-args
+ args guix-command-rest-arg-regexp
+ :group 1
+ :split? t))
+
+(defun guix-command-post-process-rest-multiple-leave (args)
+ "Modify ARGS by splitting '-- ARG ...' into multiple subarguments
+and moving them to the end of ARGS list.
+Leave '--' string as a separate argument."
+ (guix-command-post-process-matching-args
+ args guix-command-rest-arg-regexp
+ :split? t))
+
+(defun guix-command-post-process-package-args (args)
+ "Adjust popup ARGS for 'guix package' command."
+ (guix-command-post-process-matching-args
+ args (rx string-start (or "--install " "--remove ") (+ any))
+ :split? t))
+
+(defun guix-command-post-process-environment-packages (args)
+ "Adjust popup ARGS for specified packages of 'guix environment'
+command."
+ (guix-command-post-process-matching-args
+ args (rx string-start "++packages " (group (+ any)))
+ :group 1
+ :split? t))
+
+(defun guix-command-post-process-environment-ad-hoc (args)
+ "Adjust popup ARGS for '--ad-hoc' argument of 'guix environment'
+command."
+ (guix-command-post-process-matching-args
+ args (rx string-start "--ad-hoc " (+ any))
+ :split? t))
+
+(defun guix-command-post-process-args (commands args)
+ "Adjust popup ARGS for guix COMMANDS."
+ (let* ((command (car commands))
+ (processors
+ (append (guix-assoc-value guix-command-post-processors commands)
+ (guix-assoc-value guix-command-post-processors command))))
+ (guix-modify args
+ (or processors
+ (list #'guix-command-post-process-rest-multiple)))))
+
\f
;;; 'Execute' actions
"List of default 'execute' action arguments.")
(defvar guix-command-additional-execute-arguments
- nil
+ (let ((graph-arg (guix-command-make-argument
+ :name "view" :char ?v :doc "View graph")))
+ `((("build")
+ ,(guix-command-make-argument
+ :name "log" :char ?l :doc "View build log"))
+ (("graph") ,graph-arg)
+ (("size")
+ ,(guix-command-make-argument
+ :name "view" :char ?v :doc "View map"))
+ (("system" "dmd-graph") ,graph-arg)
+ (("system" "extension-graph") ,graph-arg)))
"Alist of guix commands and additional 'execute' action arguments.")
(defun guix-command-execute-arguments (commands)
'((("environment")
("repl" . guix-run-environment-command-in-repl))
(("pull")
- ("repl" . guix-run-pull-command-in-repl)))
+ ("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))
+ (("system" "dmd-graph")
+ ("view" . guix-run-view-graph))
+ (("system" "extension-graph")
+ ("view" . guix-run-view-graph)))
"Alist of guix commands and alists of special executers for them.
See also `guix-command-default-executors'.")
(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)))
+
\f
;;; Generating popups, actions, etc.
,doc
(interactive (,arguments-fun))
(,executor (append ',commands
- (guix-command-post-process-args args))))))
+ (guix-command-post-process-args
+ ',commands args))))))
(defun guix-command-generate-popup-actions (actions &optional commands)
"Generate 'popup' commands from ACTIONS arguments for guix COMMANDS."
;;;###autoload (autoload 'guix "guix-command" "Popup window for 'guix'." t)
(guix-command-define-popup-action guix)
+(defalias 'guix-edit-action #'guix-edit)
+
\f
(defvar guix-command-font-lock-keywords
(eval-when-compile
HCoop / jackhill / guix / guix.git / blobdiff