diff options
| author | Alex Kost <alezost@gmail.com> | 2016-12-22 12:47:28 +0300 |
|---|---|---|
| committer | Alex Kost <alezost@gmail.com> | 2016-12-29 23:40:24 +0300 |
| commit | deb6276dda81a69da38e842d269c5370a28fa5cf (patch) | |
| tree | 93e63ad233b0cae6e40473b020be14911cbd7aee /emacs | |
| parent | 94a6f20bafc2bb7b11cbd150779999ffa738ec7b (diff) | |
Remove Emacs interface.
* emacs/guix-about.el: Remove file.
* emacs/guix-backend.el: Likewise.
* emacs/guix-base.el: Likewise.
* emacs/guix-buffer.el: Likewise.
* emacs/guix-build-log.el: Likewise.
* emacs/guix-command.el: Likewise.
* emacs/guix-config.el.in: Likewise.
* emacs/guix-devel.el: Likewise.
* emacs/guix-entry.el: Likewise.
* emacs/guix-external.el: Likewise.
* emacs/guix-geiser.el: Likewise.
* emacs/guix-guile.el: Likewise.
* emacs/guix-help-vars.el: Likewise.
* emacs/guix-helper.scm.in: Likewise.
* emacs/guix-history.el: Likewise.
* emacs/guix-hydra-build.el: Likewise.
* emacs/guix-hydra-jobset.el: Likewise.
* emacs/guix-hydra.el: Likewise.
* emacs/guix-info.el: Likewise.
* emacs/guix-init.el: Likewise.
* emacs/guix-license.el: Likewise.
* emacs/guix-list.el: Likewise.
* emacs/guix-location.el: Likewise.
* emacs/guix-main.scm: Likewise.
* emacs/guix-messages.el: Likewise.
* emacs/guix-pcomplete.el: Likewise.
* emacs/guix-popup.el: Likewise.
* emacs/guix-prettify.el: Likewise.
* emacs/guix-profiles.el: Likewise.
* emacs/guix-read.el: Likewise.
* emacs/guix-ui-generation.el: Likewise.
* emacs/guix-ui-license.el: Likewise.
* emacs/guix-ui-location.el: Likewise.
* emacs/guix-ui-package.el: Likewise.
* emacs/guix-ui-system-generation.el: Likewise.
* emacs/guix-ui.el: Likewise.
* emacs/guix-utils.el: Likewise.
* emacs/local.mk: Likewise.
* doc/emacs.texi: Likewise.
* doc/guix.texi: Remove cross-references to Emacs nodes.
(Package Management): Mention 'emacs-guix' package.
* doc/contributing.texi (The Perfect Setup): Remove the reference.
* doc/htmlxref.cnf: Add 'emacs-guix' URL.
* Makefile.am: Remove Emacs stuff.
* configure.ac: Likewise.
* gnu/packages/package-management.scm (guix-0.12.0)[native-inputs]:
Remove "emacs".
[propagated-inputs]: Remove "geiser" and "emacs-magit-popup".
Co-authored-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'emacs')
38 files changed, 0 insertions, 11065 deletions
diff --git a/emacs/guix-about.el b/emacs/guix-about.el deleted file mode 100644 index 27a79fe162..0000000000 --- a/emacs/guix-about.el +++ /dev/null @@ -1,37 +0,0 @@ -;;; guix-about.el --- Various info about Guix - -;; Copyright © 2016 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see <http://www.gnu.org/locations/>. - -;;; Commentary: - -;; This file provides the code to display various info about Guix (e.g., its -;; version). - -;;; Code: - -(require 'guix-config) - -;;;###autoload -(defun guix-version () - "Display Guix version in the echo area." - (interactive) - (message "%s %s" guix-config-name guix-config-version)) - -(provide 'guix-about) - -;;; guix-about.el ends here diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el deleted file mode 100644 index 6341aacae1..0000000000 --- a/emacs/guix-backend.el +++ /dev/null @@ -1,393 +0,0 @@ -;;; guix-backend.el --- Making and using Guix REPL - -;; Copyright © 2014, 2015, 2016 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 the code for interacting with Guile using Guix REPL -;; (Geiser REPL with some guix-specific additions). - -;; By default (if `guix-use-guile-server' is non-nil) 2 Guix REPLs are -;; started. The main one (with "guile --listen" process) is used for -;; "interacting" with a user - for showing a progress of -;; installing/deleting Guix packages. The second (internal) REPL is -;; used for synchronous evaluating, e.g. when information about -;; packages/generations should be received for a list/info buffer. -;; -;; This "2 REPLs concept" makes it possible to have a running process of -;; installing/deleting packages and to continue to search/list/get info -;; about other packages at the same time. If you prefer to use a single -;; Guix REPL, do not try to receive any information while there is a -;; running code in the REPL (see -;; <https://github.com/jaor/geiser/issues/28>). -;; -;; Guix REPLs (unlike the usual Geiser REPLs) are not added to -;; `geiser-repl--repls' variable, and thus cannot be used for evaluating -;; while editing scm-files. The only purpose of Guix REPLs is to be an -;; intermediate between "Guix/Guile level" and "Emacs interface level". -;; That being said you can still want to use a Guix REPL while hacking -;; auxiliary scheme-files for "guix.el". You can just use -;; `geiser-connect-local' command with `guix-repl-current-socket' to -;; have a usual Geiser REPL with all stuff defined by "guix.el" package. - -;;; Code: - -(require 'geiser-mode) -(require 'geiser-guile) -(require 'guix-geiser) -(require 'guix-config) -(require 'guix-external) -(require 'guix-emacs) -(require 'guix-profiles) - -(defvar guix-load-path guix-config-emacs-interface-directory - "Directory with scheme files for \"guix.el\" package.") - -(defvar guix-helper-file - (expand-file-name "guix-helper.scm" guix-load-path) - "Auxiliary scheme file for loading.") - - -;;; REPL - -(defgroup guix-repl nil - "Settings for Guix REPLs." - :prefix "guix-repl-" - :group 'guix) - -(defcustom guix-repl-startup-time 30000 - "Time, in milliseconds, to wait for Guix REPL to startup. -Same as `geiser-repl-startup-time' but is used for Guix REPL. -If you have a slow system, try to increase this time." - :type 'integer - :group 'guix-repl) - -(defcustom guix-repl-buffer-name "*Guix REPL*" - "Default name of a Geiser REPL buffer used for Guix." - :type 'string - :group 'guix-repl) - -(defcustom guix-after-start-repl-hook '(guix-set-directory) - "Hook called after Guix REPL is started." - :type 'hook - :group 'guix-repl) - -(defcustom guix-use-guile-server t - "If non-nil, start guile with '--listen' argument. -This allows to receive information about packages using an additional -REPL while some packages are being installed/removed in the main REPL." - :type 'boolean - :group 'guix-repl) - -(defcustom guix-repl-socket-file-name-function - #'guix-repl-socket-file-name - "Function used to define a socket file name used by Guix REPL. -The function is called without arguments." - :type '(choice (function-item guix-repl-socket-file-name) - (function :tag "Other function")) - :group 'guix-repl) - -(defcustom guix-emacs-activate-after-operation t - "Activate Emacs packages after installing. -If nil, do not load autoloads of the Emacs packages after -they are successfully installed." - :type 'boolean - :group 'guix-repl) - -(defvar guix-repl-current-socket nil - "Name of a socket file used by the current Guix REPL.") - -(defvar guix-repl-buffer nil - "Main Geiser REPL buffer used for communicating with Guix. -This REPL is used for processing package actions and for -receiving information if `guix-use-guile-server' is nil.") - -(defvar guix-internal-repl-buffer nil - "Additional Geiser REPL buffer used for communicating with Guix. -This REPL is used for receiving information only if -`guix-use-guile-server' is non-nil.") - -(defvar guix-internal-repl-buffer-name "*Guix Internal REPL*" - "Default name of an internal Guix REPL buffer.") - -(defvar guix-before-repl-operation-hook nil - "Hook run before executing an operation in Guix REPL.") - -(defvar guix-after-repl-operation-hook - '(guix-repl-autoload-emacs-packages-maybe - guix-repl-operation-success-message) - "Hook run after executing successful operation in Guix REPL.") - -(defvar guix-repl-operation-p nil - "Non-nil, if current operation is performed by `guix-eval-in-repl'. -This internal variable is used to distinguish Guix operations -from operations performed in Guix REPL by a user.") - -(defvar guix-repl-operation-type nil - "Type of the current operation performed by `guix-eval-in-repl'. -This internal variable is used to define what actions should be -executed after the current operation succeeds. -See `guix-eval-in-repl' for details.") - -(defun guix-repl-autoload-emacs-packages-maybe () - "Load autoloads for Emacs packages if needed. -See `guix-emacs-activate-after-operation' for details." - (and guix-emacs-activate-after-operation - ;; FIXME Since a user can work with a non-current profile (using - ;; C-u before `guix-search-by-name' and other commands), emacs - ;; packages can be installed to another profile, and the - ;; following code will not work (i.e., the autoloads for this - ;; profile will not be loaded). - (guix-emacs-autoload-packages guix-current-profile))) - -(defun guix-repl-operation-success-message () - "Message telling about successful Guix operation." - (message "Guix operation has been performed.")) - -(defun guix-get-guile-program (&optional socket) - "Return a value suitable for `geiser-guile-binary'." - (if (null socket) - guix-guile-program - (append (if (listp guix-guile-program) - guix-guile-program - (list guix-guile-program)) - (list (concat "--listen=" socket))))) - -(defun guix-repl-socket-file-name () - "Return a name of a socket file used by Guix REPL." - (make-temp-name - (concat (file-name-as-directory temporary-file-directory) - "guix-repl-"))) - -(defun guix-repl-delete-socket-maybe () - "Delete `guix-repl-current-socket' file if it exists." - (and guix-repl-current-socket - (file-exists-p guix-repl-current-socket) - (delete-file guix-repl-current-socket))) - -(add-hook 'kill-emacs-hook 'guix-repl-delete-socket-maybe) - -(defun guix-start-process-maybe (&optional start-msg end-msg) - "Start Geiser REPL configured for Guix if needed. -START-MSG and END-MSG are strings displayed in the minibuffer in -the beginning and in the end of the starting process. If nil, -display default messages." - (guix-start-repl-maybe nil - (or start-msg "Starting Guix REPL ...") - (or end-msg "Guix REPL has been started.")) - (if guix-use-guile-server - (guix-start-repl-maybe 'internal) - (setq guix-internal-repl-buffer guix-repl-buffer))) - -(defun guix-start-repl-maybe (&optional internal start-msg end-msg) - "Start Guix REPL if needed. -If INTERNAL is non-nil, start an internal REPL. - -START-MSG and END-MSG are strings displayed in the minibuffer in -the beginning and in the end of the process. If nil, do not -display messages." - (let* ((repl-var (guix-get-repl-buffer-variable internal)) - (repl (symbol-value repl-var))) - (unless (and (buffer-live-p repl) - (get-buffer-process repl)) - (and start-msg (message start-msg)) - (setq guix-repl-operation-p nil) - (unless internal - ;; Guile leaves socket file after exit, so remove it if it - ;; exists (after the REPL restart). - (guix-repl-delete-socket-maybe) - (setq guix-repl-current-socket - (and guix-use-guile-server - (or guix-repl-current-socket - (funcall guix-repl-socket-file-name-function))))) - (let ((geiser-guile-binary (guix-get-guile-program - (unless internal - guix-repl-current-socket))) - (geiser-guile-init-file (unless internal guix-helper-file)) - (repl (get-buffer-create - (guix-get-repl-buffer-name internal)))) - (guix-start-repl repl (and internal guix-repl-current-socket)) - (set repl-var repl) - (and end-msg (message end-msg)) - (unless internal - (run-hooks 'guix-after-start-repl-hook)))))) - -(defun guix-start-repl (buffer &optional address) - "Start Guix REPL in BUFFER. -If ADDRESS is non-nil, connect to a remote guile process using -this address (it should be defined by -`geiser-repl--read-address')." - ;; A mix of the code from `geiser-repl--start-repl' and - ;; `geiser-repl--to-repl-buffer'. - (let ((impl 'guile) - (geiser-guile-load-path (cons (expand-file-name guix-load-path) - geiser-guile-load-path)) - (geiser-repl-startup-time guix-repl-startup-time)) - (with-current-buffer buffer - (geiser-repl-mode) - (geiser-impl--set-buffer-implementation impl) - (geiser-repl--autodoc-mode -1) - (goto-char (point-max)) - (let ((prompt (geiser-con--combined-prompt - geiser-guile--prompt-regexp - geiser-guile--debugger-prompt-regexp))) - (geiser-repl--save-remote-data address) - (geiser-repl--start-scheme impl address prompt) - (geiser-repl--quit-setup) - (geiser-repl--history-setup) - (setq-local geiser-repl--repls (list buffer)) - (geiser-repl--set-this-buffer-repl buffer) - (setq geiser-repl--connection - (geiser-con--make-connection - (get-buffer-process (current-buffer)) - geiser-guile--prompt-regexp - geiser-guile--debugger-prompt-regexp)) - (geiser-repl--startup impl address) - (geiser-repl--autodoc-mode 1) - (geiser-company--setup geiser-repl-company-p) - (add-hook 'comint-output-filter-functions - 'guix-repl-output-filter - nil t) - (set-process-query-on-exit-flag - (get-buffer-process (current-buffer)) - geiser-repl-query-on-kill-p))))) - -(defun guix-repl-output-filter (str) - "Filter function suitable for `comint-output-filter-functions'. -This is a replacement for `geiser-repl--output-filter'." - (cond - ((string-match-p geiser-guile--prompt-regexp str) - (geiser-autodoc--disinhibit-autodoc) - (when guix-repl-operation-p - (setq guix-repl-operation-p nil) - (run-hooks 'guix-after-repl-operation-hook) - ;; Run hooks specific to the current operation type. - (when guix-repl-operation-type - (let ((type-hook (intern - (concat "guix-after-" - (symbol-name guix-repl-operation-type) - "-hook")))) - (setq guix-repl-operation-type nil) - (and (boundp type-hook) - (run-hooks type-hook)))))) - ((string-match geiser-guile--debugger-prompt-regexp str) - (setq guix-repl-operation-p nil) - (geiser-con--connection-set-debugging geiser-repl--connection - (match-beginning 0)) - (geiser-autodoc--disinhibit-autodoc)))) - -(defun guix-repl-exit (&optional internal no-wait) - "Exit the current Guix REPL. -If INTERNAL is non-nil, exit the internal REPL. -If NO-WAIT is non-nil, do not wait for the REPL process to exit: -send a kill signal to it and return immediately." - (let ((repl (symbol-value (guix-get-repl-buffer-variable internal)))) - (when (get-buffer-process repl) - (with-current-buffer repl - (geiser-con--connection-deactivate geiser-repl--connection t) - (comint-kill-subjob) - (unless no-wait - (while (get-buffer-process repl) - (sleep-for 0.1))))))) - -(defun guix-get-repl-buffer (&optional internal) - "Return Guix REPL buffer; start REPL if needed. -If INTERNAL is non-nil, return an additional internal REPL." - (guix-start-process-maybe) - (let ((repl (symbol-value (guix-get-repl-buffer-variable internal)))) - ;; If a new Geiser REPL is started, `geiser-repl--repl' variable may - ;; be set to the new value in a Guix REPL, so set it back to a - ;; proper value here. - (with-current-buffer repl - (geiser-repl--set-this-buffer-repl repl)) - repl)) - -(defun guix-get-repl-buffer-variable (&optional internal) - "Return the name of a variable with a REPL buffer." - (if internal - 'guix-internal-repl-buffer - 'guix-repl-buffer)) - -(defun guix-get-repl-buffer-name (&optional internal) - "Return the name of a REPL buffer." - (if internal - guix-internal-repl-buffer-name - guix-repl-buffer-name)) - -(defun guix-switch-to-repl (&optional internal) - "Switch to Guix REPL. -If INTERNAL is non-nil (interactively with prefix), switch to the -additional internal REPL if it exists." - (interactive "P") - (geiser-repl--switch-to-buffer (guix-get-repl-buffer internal))) - - -;;; Guix directory - -(defvar guix-directory nil - "Default directory with Guix source. -If it is not set by a user, it is set after starting Guile REPL. -This directory is used to define package locations.") - -(defun guix-read-directory () - "Return `guix-directory' or prompt for it. -This function is intended for using in `interactive' forms." - (if current-prefix-arg - (read-directory-name "Directory with Guix modules: " - guix-directory) - guix-directory)) - -(defun guix-set-directory () - "Set `guix-directory' if needed." - (or guix-directory - (setq guix-directory - (guix-eval-read "%guix-dir")))) - - -;;; Evaluating expressions - -(defvar guix-operation-buffer nil - "Buffer from which the latest Guix operation was performed.") - -(defun guix-eval (str) - "Evaluate STR with guile expression using Guix REPL. -See `guix-geiser-eval' for details." - (guix-geiser-eval str (guix-get-repl-buffer 'internal))) - -(defun guix-eval-read (str) - "Evaluate STR with guile expression using Guix REPL. -See `guix-geiser-eval-read' for details." - (guix-geiser-eval-read str (guix-get-repl-buffer 'internal))) - -(defun guix-eval-in-repl (str &optional operation-buffer operation-type) - "Switch to Guix REPL and evaluate STR with guile expression there. -If OPERATION-BUFFER is non-nil, it should be a buffer from which -the current operation was performed. - -If OPERATION-TYPE is non-nil, it should be a symbol. After -successful executing of the current operation, -`guix-after-OPERATION-TYPE-hook' is called." - (run-hooks 'guix-before-repl-operation-hook) - (setq guix-repl-operation-p t - guix-repl-operation-type operation-type - guix-operation-buffer operation-buffer) - (guix-geiser-eval-in-repl str (guix-get-repl-buffer))) - -(provide 'guix-backend) - -;;; guix-backend.el ends here diff --git a/emacs/guix-base.el b/emacs/guix-base.el deleted file mode 100644 index 658cfdb5fa..0000000000 --- a/emacs/guix-base.el +++ /dev/null @@ -1,377 +0,0 @@ -;;; guix-base.el --- Common definitions -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 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 some base and common definitions for guix.el -;; package. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-read) -(require 'guix-utils) -(require 'guix-ui) -(require 'guix-profiles) - -(defgroup guix nil - "Settings for Guix package manager and friends." - :prefix "guix-" - :group 'external) - -(defgroup guix-faces nil - "Guix faces." - :group 'guix - :group 'faces) - -(defun guix-package-name-specification (name version &optional output) - "Return Guix package specification by its NAME, VERSION and OUTPUT." - (concat name "@" version - (when output (concat ":" output)))) - - -;;; Location of profiles and manifests - -(defun guix-generation-file (profile generation) - "Return the file name of a PROFILE's GENERATION." - (format "%s-%s-link" profile generation)) - -(defun guix-packages-profile (profile &optional generation system?) - "Return a directory where packages are installed for the -PROFILE's GENERATION. - -If SYSTEM? is non-nil, then PROFILE is considered to be a system -profile. Unlike usual profiles, for a system profile, packages -are placed in 'profile' subdirectory." - (let ((profile (if generation - (guix-generation-file profile generation) - profile))) - (if system? - (expand-file-name "profile" profile) - profile))) - -(defun guix-manifest-file (profile &optional generation system?) - "Return the file name of a PROFILE's manifest. -See `guix-packages-profile'." - (expand-file-name "manifest" - (guix-packages-profile profile generation system?))) - - -;;; Actions on packages and generations - -(defface guix-operation-option-key - '((t :inherit font-lock-warning-face)) - "Face used for the keys of operation options." - :group 'guix-faces) - -(defcustom guix-operation-confirm t - "If nil, do not prompt to confirm an operation." - :type 'boolean - :group 'guix) - -(defcustom guix-use-substitutes t - "If non-nil, use substitutes for the Guix packages." - :type 'boolean - :group 'guix) - -(defvar guix-dry-run nil - "If non-nil, do not perform the real actions, just simulate.") - -(defvar guix-temp-buffer-name " *Guix temp*" - "Name of a buffer used for displaying info before executing operation.") - -(defvar guix-operation-option-true-string "yes" - "String displayed in the mode-line when operation option is t.") - -(defvar guix-operation-option-false-string "no " - "String displayed in the mode-line when operation option is nil.") - -(defvar guix-operation-option-separator " | " - "String used in the mode-line to separate operation options.") - -(defvar guix-operation-options - '((?s "substitutes" guix-use-substitutes) - (?d "dry-run" guix-dry-run)) - "List of available operation options. -Each element of the list has a form: - - (KEY NAME VARIABLE) - -KEY is a character that may be pressed during confirmation to -toggle the option. -NAME is a string displayed in the mode-line. -VARIABLE is a name of an option variable.") - -(defun guix-operation-option-by-key (key) - "Return operation option by KEY (character)." - (assq key guix-operation-options)) - -(defun guix-operation-option-key (option) - "Return key (character) of the operation OPTION." - (car option)) - -(defun guix-operation-option-name (option) - "Return name of the operation OPTION." - (nth 1 option)) - -(defun guix-operation-option-variable (option) - "Return name of the variable of the operation OPTION." - (nth 2 option)) - -(defun guix-operation-option-value (option) - "Return boolean value of the operation OPTION." - (symbol-value (guix-operation-option-variable option))) - -(defun guix-operation-option-string-value (option) - "Convert boolean value of the operation OPTION to string and return it." - (if (guix-operation-option-value option) - guix-operation-option-true-string - guix-operation-option-false-string)) - -(defun guix-operation-prompt (&optional prompt) - "Prompt a user for continuing the current operation. -Return non-nil, if the operation should be continued; nil otherwise. -Ask a user with PROMPT for continuing an operation." - (let* ((option-keys (mapcar #'guix-operation-option-key - guix-operation-options)) - (keys (append '(?y ?n) option-keys)) - (prompt (concat (propertize (or prompt "Continue operation?") - 'face 'minibuffer-prompt) - " (" - (mapconcat - (lambda (key) - (propertize (string key) - 'face 'guix-operation-option-key)) - keys - ", ") - ") "))) - (let ((mode-line mode-line-format)) - (prog1 (guix-operation-prompt-1 prompt keys) - (setq mode-line-format mode-line) - ;; Clear the minibuffer after prompting. - (message ""))))) - -(defun guix-operation-prompt-1 (prompt keys) - "This function is internal for `guix-operation-prompt'." - (guix-operation-set-mode-line) - (let ((key (read-char-choice prompt (cons ?\C-g keys) t))) - (cl-case key - (?y t) - ((?n ?\C-g) nil) - (t (let* ((option (guix-operation-option-by-key key)) - (var (guix-operation-option-variable option))) - (set var (not (symbol-value var))) - (guix-operation-prompt-1 prompt keys)))))) - -(defun guix-operation-set-mode-line () - "Display operation options in the mode-line of the current buffer." - (setq mode-line-format - (concat (propertize " Options: " - 'face 'mode-line-buffer-id) - (mapconcat - (lambda (option) - (let ((key (guix-operation-option-key option)) - (name (guix-operation-option-name option)) - (val (guix-operation-option-string-value option))) - (concat name - " (" - (propertize (string key) - 'face 'guix-operation-option-key) - "): " val))) - guix-operation-options - guix-operation-option-separator))) - (force-mode-line-update)) - -(defun guix-package-source-path (package-id) - "Return a store file path to a source of a package PACKAGE-ID." - (message "Calculating the source derivation ...") - (guix-eval-read - (guix-make-guile-expression - 'package-source-path package-id))) - -(defun guix-package-store-path (package-id) - "Return a list of store directories of outputs of package PACKAGE-ID." - (message "Calculating the package derivation ...") - (guix-eval-read - (guix-make-guile-expression - 'package-store-path package-id))) - -(defvar guix-after-source-download-hook nil - "Hook run after successful performing a 'source-download' operation.") - -(defun guix-package-source-build-derivation (package-id &optional prompt) - "Build source derivation of a package PACKAGE-ID. -Ask a user with PROMPT for continuing an operation." - (when (or (not guix-operation-confirm) - (guix-operation-prompt (or prompt - "Build the source derivation?"))) - (guix-eval-in-repl - (guix-make-guile-expression - 'package-source-build-derivation - package-id - :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)) - nil 'source-download))) - -(defun guix-build-package (package-id &optional prompt) - "Build package with PACKAGE-ID. -Ask a user with PROMPT for continuing the build operation." - (when (or (not guix-operation-confirm) - (guix-operation-prompt (or prompt "Build package?"))) - (guix-eval-in-repl - (format (concat ",run-in-store " - "(build-package (package-by-id %d)" - " #:use-substitutes? %s" - " #:dry-run? %s)") - package-id - (guix-guile-boolean guix-use-substitutes) - (guix-guile-boolean guix-dry-run))))) - -;;;###autoload -(defun guix-apply-manifest (profile file &optional operation-buffer) - "Apply manifest from FILE to PROFILE. -This function has the same meaning as 'guix package --manifest' command. -See Info node `(guix) Invoking guix package' for details. - -Interactively, use the current profile and prompt for manifest -FILE. With a prefix argument, also prompt for PROFILE." - (interactive - (let* ((current-profile (guix-ui-current-profile)) - (profile (if current-prefix-arg - (guix-profile-prompt) - (or current-profile guix-current-profile))) - (file (read-file-name "File with manifest: ")) - (buffer (and current-profile (current-buffer)))) - (list profile file buffer))) - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Apply manifest from '%s' to profile '%s'? " - file profile))) - (guix-eval-in-repl - (guix-make-guile-expression - 'guix-command - "package" - (concat "--profile=" (expand-file-name profile)) - (concat "--manifest=" (expand-file-name file))) - operation-buffer))) - - -;;; Executing guix commands - -(defcustom guix-run-in-shell-function #'guix-run-in-shell - "Function used to run guix command. -The function is called with a single argument - a command line string." - :type '(choice (function-item guix-run-in-shell) - (function-item guix-run-in-eshell) - (function :tag "Other function")) - :group 'guix) - -(defcustom guix-shell-buffer-name "*shell*" - "Default name of a shell buffer used for running guix commands." - :type 'string - :group 'guix) - -(declare-function comint-send-input "comint" t) - -(defun guix-run-in-shell (string) - "Run command line STRING in `guix-shell-buffer-name' buffer." - (shell guix-shell-buffer-name) - (goto-char (point-max)) - (insert string) - (comint-send-input)) - -(declare-function eshell-send-input "esh-mode" t) - -(defun guix-run-in-eshell (string) - "Run command line STRING in eshell buffer." - (eshell) - (goto-char (point-max)) - (insert string) - (eshell-send-input)) - -(defun guix-run-command-in-shell (args) - "Execute 'guix ARGS ...' command in a shell buffer." - (funcall guix-run-in-shell-function - (guix-command-string args))) - -(defun guix-run-command-in-repl (args) - "Execute 'guix ARGS ...' command in Guix REPL." - (guix-eval-in-repl - (apply #'guix-make-guile-expression - 'guix-command args))) - -(defun guix-command-output (args) - "Return string with 'guix ARGS ...' output." - (cl-multiple-value-bind (output error) - (guix-eval (apply #'guix-make-guile-expression - 'guix-command-output args)) - ;; Remove trailing new space from the error string. - (message (replace-regexp-in-string "\n\\'" "" (read error))) - (read output))) - -(defun guix-help-string (&optional commands) - "Return string with 'guix COMMANDS ... --help' output." - (guix-eval-read - (apply #'guix-make-guile-expression - 'help-string commands))) - - -;;; Pull - -(defcustom guix-update-after-pull t - "If non-nil, update Guix buffers after performing \\[guix-pull]." - :type 'boolean - :group 'guix) - -(defvar guix-after-pull-hook - '(guix-restart-repl-after-pull guix-update-buffers-maybe-after-pull) - "Hook run after successful performing `guix-pull' operation.") - -(defun guix-restart-repl-after-pull () - "Restart Guix REPL after `guix-pull' operation." - (guix-repl-exit) - (guix-start-process-maybe - "Restarting Guix REPL after pull operation ...")) - -(defun guix-update-buffers-maybe-after-pull () - "Update buffers depending on `guix-update-after-pull'." - (when guix-update-after-pull - (mapc #'guix-ui-update-buffer - ;; No need to update "generation" buffers. - (guix-ui-buffers '(guix-package-list-mode - guix-package-info-mode - guix-output-list-mode - guix-output-info-mode))) - (message "Guix buffers have been updated."))) - -;;;###autoload -(defun guix-pull (&optional verbose) - "Run Guix pull operation. -If VERBOSE is non-nil (with prefix argument), produce verbose output." - (interactive "P") - (let ((args (and verbose '("--verbose")))) - (guix-eval-in-repl - (apply #'guix-make-guile-expression - 'guix-command "pull" args) - nil 'pull))) - -(provide 'guix-base) - -;;; guix-base.el ends here diff --git a/emacs/guix-buffer.el b/emacs/guix-buffer.el deleted file mode 100644 index 4cefe9989e..0000000000 --- a/emacs/guix-buffer.el +++ /dev/null @@ -1,624 +0,0 @@ -;;; guix-buffer.el --- Buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 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 general 'buffer' interface for displaying an -;; arbitrary data. - -;;; Code: - -(require 'cl-lib) -(require 'guix-history) -(require 'guix-utils) - -(defvar guix-buffer-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "l") 'guix-history-back) - (define-key map (kbd "r") 'guix-history-forward) - (define-key map (kbd "g") 'revert-buffer) - (define-key map (kbd "R") 'guix-buffer-redisplay) - map) - "Parent keymap for Guix buffer modes.") - - -;;; Buffer item - -(cl-defstruct (guix-buffer-item - (:constructor nil) - (:constructor guix-buffer-make-item - (entries buffer-type entry-type args)) - (:copier nil)) - entries buffer-type entry-type args) - -(defvar-local guix-buffer-item nil - "Data (structure) for the current Guix buffer. -The structure consists of the following elements: - -- `entries': list of the currently displayed entries. - - Each element of the list is an alist with an entry data of the - following form: - - ((PARAM . VAL) ...) - - PARAM is a name of the entry parameter. - VAL is a value of this parameter. - -- `entry-type': type of the currently displayed entries. - -- `buffer-type': type of the current buffer. - -- `args': search arguments used to get the current entries.") -(put 'guix-buffer-item 'permanent-local t) - -(defmacro guix-buffer-with-item (item &rest body) - "Evaluate BODY using buffer ITEM. -The following local variables are available inside BODY: -`%entries', `%buffer-type', `%entry-type', `%args'. -See `guix-buffer-item' for details." - (declare (indent 1) (debug t)) - (let ((item-var (make-symbol "item"))) - `(let ((,item-var ,item)) - (let ((%entries (guix-buffer-item-entries ,item-var)) - (%buffer-type (guix-buffer-item-buffer-type ,item-var)) - (%entry-type (guix-buffer-item-entry-type ,item-var)) - (%args (guix-buffer-item-args ,item-var))) - ,@body)))) - -(defmacro guix-buffer-with-current-item (&rest body) - "Evaluate BODY using `guix-buffer-item'. -See `guix-buffer-with-item' for details." - (declare (indent 0) (debug t)) - `(guix-buffer-with-item guix-buffer-item - ,@body)) - -(defmacro guix-buffer-define-current-item-accessor (name) - "Define `guix-buffer-current-NAME' function to access NAME -element of `guix-buffer-item' structure. -NAME should be a symbol." - (let* ((name-str (symbol-name name)) - (accessor (intern (concat "guix-buffer-item-" name-str))) - (fun-name (intern (concat "guix-buffer-current-" name-str))) - (doc (format "\ -Return '%s' of the current Guix buffer. -See `guix-buffer-item' for details." - name-str))) - `(defun ,fun-name () - ,doc - (and guix-buffer-item - (,accessor guix-buffer-item))))) - -(defmacro guix-buffer-define-current-item-accessors (&rest names) - "Define `guix-buffer-current-NAME' functions for NAMES. -See `guix-buffer-define-current-item-accessor' for details." - `(progn - ,@(mapcar (lambda (name) - `(guix-buffer-define-current-item-accessor ,name)) - names))) - -(guix-buffer-define-current-item-accessors - entries entry-type buffer-type args) - -(defmacro guix-buffer-define-current-args-accessor (n prefix name) - "Define `PREFIX-NAME' function to access Nth element of 'args' -field of `guix-buffer-item' structure. -PREFIX and NAME should be strings." - (let ((fun-name (intern (concat prefix "-" name))) - (doc (format "\ -Return '%s' of the current Guix buffer. -'%s' is the element number %d in 'args' of `guix-buffer-item'." - name name n))) - `(defun ,fun-name () - ,doc - (nth ,n (guix-buffer-current-args))))) - -(defmacro guix-buffer-define-current-args-accessors (prefix &rest names) - "Define `PREFIX-NAME' functions for NAMES. -See `guix-buffer-define-current-args-accessor' for details." - `(progn - ,@(cl-loop for name in names - for i from 0 - collect `(guix-buffer-define-current-args-accessor - ,i ,prefix ,name)))) - - -;;; Wrappers for defined variables - -(defvar guix-buffer-data nil - "Alist with 'buffer' data. -This alist is filled by `guix-buffer-define-interface' macro.") - -(defun guix-buffer-value (buffer-type entry-type symbol) - "Return SYMBOL's value for BUFFER-TYPE/ENTRY-TYPE from `guix-buffer-data'." - (symbol-value - (guix-assq-value guix-buffer-data buffer-type entry-type symbol))) - -(defun guix-buffer-get-entries (buffer-type entry-type args) - "Return ENTRY-TYPE entries. -Call an appropriate 'get-entries' function from `guix-buffer' -using ARGS as its arguments." - (apply (guix-buffer-value buffer-type entry-type 'get-entries) - args)) - -(defun guix-buffer-mode-enable (buffer-type entry-type) - "Turn on major mode to display ENTRY-TYPE ENTRIES in BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'mode))) - -(defun guix-buffer-mode-initialize (buffer-type entry-type) - "Set up the current BUFFER-TYPE buffer to display ENTRY-TYPE entries." - (let ((fun (guix-buffer-value buffer-type entry-type 'mode-init))) - (when fun - (funcall fun)))) - -(defun guix-buffer-insert-entries (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'insert-entries) - entries)) - -(defun guix-buffer-show-entries-default (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (let ((inhibit-read-only t)) - (erase-buffer) - (guix-buffer-mode-enable buffer-type entry-type) - (guix-buffer-insert-entries entries buffer-type entry-type) - (goto-char (point-min)))) - -(defun guix-buffer-show-entries (entries buffer-type entry-type) - "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (funcall (guix-buffer-value buffer-type entry-type 'show-entries) - entries)) - -(defun guix-buffer-message (entries buffer-type entry-type args) - "Display a message for BUFFER-ITEM after showing entries." - (let ((fun (guix-buffer-value buffer-type entry-type 'message))) - (when fun - (apply fun entries args)))) - -(defun guix-buffer-name (buffer-type entry-type args) - "Return name of BUFFER-TYPE buffer for displaying ENTRY-TYPE entries." - (let ((str-or-fun (guix-buffer-value buffer-type entry-type - 'buffer-name))) - (if (stringp str-or-fun) - str-or-fun - (apply str-or-fun args)))) - -(defun guix-buffer-param-title (buffer-type entry-type param) - "Return PARAM title for BUFFER-TYPE/ENTRY-TYPE." - (or (guix-assq-value (guix-buffer-value buffer-type entry-type 'titles) - param) - ;; Fallback to a title defined in 'info' interface. - (unless (eq buffer-type 'info) - (guix-assq-value (guix-buffer-value 'info entry-type 'titles) - param)) - (guix-symbol-title param))) - -(defun guix-buffer-history-size (buffer-type entry-type) - "Return history size for BUFFER-TYPE/ENTRY-TYPE." - (guix-buffer-value buffer-type entry-type 'history-size)) - -(defun guix-buffer-revert-confirm? (buffer-type entry-type) - "Return 'revert-confirm' value for BUFFER-TYPE/ENTRY-TYPE." - (guix-buffer-value buffer-type entry-type 'revert-confirm)) - - -;;; Displaying entries - -(defun guix-buffer-display (buffer) - "Switch to a Guix BUFFER." - (pop-to-buffer buffer - '((display-buffer-reuse-window - display-buffer-same-window)))) - -(defun guix-buffer-history-item (buffer-item) - "Make and return a history item for displaying BUFFER-ITEM." - (list #'guix-buffer-set buffer-item)) - -(defun guix-buffer-set (buffer-item &optional history) - "Set up the current buffer for displaying BUFFER-ITEM. -HISTORY should be one of the following: - - `nil' - do not save BUFFER-ITEM in history, - - `add' - add it to history, - - `replace' - replace the current history item." - (guix-buffer-with-item buffer-item - (when %entries - ;; Set buffer item before showing entries, so that its value can - ;; be used by the code for displaying entries. - (setq guix-buffer-item buffer-item) - (guix-buffer-show-entries %entries %buffer-type %entry-type) - (when history - (funcall (cl-ecase history - (add #'guix-history-add) - (replace #'guix-history-replace)) - (guix-buffer-history-item buffer-item)))) - (guix-buffer-message %entries %buffer-type %entry-type %args))) - -(defun guix-buffer-display-entries-current - (entries buffer-type entry-type args &optional history) - "Show ENTRIES in the current Guix buffer. -See `guix-buffer-item' for the meaning of BUFFER-TYPE, ENTRY-TYPE -and ARGS, and `guix-buffer-set' for the meaning of HISTORY." - (let ((item (guix-buffer-make-item entries buffer-type - entry-type args))) - (guix-buffer-set item history))) - -(defun guix-buffer-get-display-entries-current - (buffer-type entry-type args &optional history) - "Search for entries and show them in the current Guix buffer. -See `guix-buffer-display-entries-current' for details." - (guix-buffer-display-entries-current - (guix-buffer-get-entries buffer-type entry-type args) - buffer-type entry-type args history)) - -(defun guix-buffer-display-entries - (entries buffer-type entry-type args &optional history) - "Show ENTRIES in a BUFFER-TYPE buffer. -See `guix-buffer-display-entries-current' for details." - (let ((buffer (get-buffer-create - (guix-buffer-name buffer-type entry-type args)))) - (with-current-buffer buffer - (guix-buffer-display-entries-current - entries buffer-type entry-type args history)) - (when entries - (guix-buffer-display buffer)))) - -(defun guix-buffer-get-display-entries - (buffer-type entry-type args &optional history) - "Search for entries and show them in a BUFFER-TYPE buffer. -See `guix-buffer-display-entries-current' for details." - (guix-buffer-display-entries - (guix-buffer-get-entries buffer-type entry-type args) - buffer-type entry-type args history)) - -(defun guix-buffer-revert (_ignore-auto noconfirm) - "Update the data in the current Guix buffer. -This function is suitable for `revert-buffer-function'. -See `revert-buffer' for the meaning of NOCONFIRM." - (guix-buffer-with-current-item - (when (or noconfirm - (not (guix-buffer-revert-confirm? %buffer-type %entry-type)) - (y-or-n-p "Update the current buffer? ")) - (guix-buffer-get-display-entries-current - %buffer-type %entry-type %args 'replace)))) - -(defvar guix-buffer-after-redisplay-hook nil - "Hook run by `guix-buffer-redisplay'. -This hook is called before seting up a window position.") - -(defun guix-buffer-redisplay () - "Redisplay the current Guix buffer. -Restore the point and window positions after redisplaying. - -This function does not update the buffer data, use -'\\[revert-buffer]' if you want the full update." - (interactive) - (let* ((old-point (point)) - ;; For simplicity, ignore an unlikely case when multiple - ;; windows display the same buffer. - (window (car (get-buffer-window-list (current-buffer) nil t))) - (window-start (and window (window-start window)))) - (guix-buffer-set guix-buffer-item) - (goto-char old-point) - (run-hooks 'guix-buffer-after-redisplay-hook) - (when window - (set-window-point window (point)) - (set-window-start window window-start)))) - -(defun guix-buffer-redisplay-goto-button () - "Redisplay the current buffer and go to the next button, if needed." - (let ((guix-buffer-after-redisplay-hook - (cons (lambda () - (unless (button-at (point)) - (forward-button 1))) - guix-buffer-after-redisplay-hook))) - (guix-buffer-redisplay))) - - -;;; Interface definers - -(defmacro guix-define-groups (type &rest args) - "Define `guix-TYPE' and `guix-TYPE-faces' custom groups. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:parent-group' - name of a parent custom group. - - - `:parent-faces-group' - name of a parent custom faces group. - - - `:group-doc' - docstring of a `guix-TYPE' group. - - - `:faces-group-doc' - docstring of a `guix-TYPE-faces' group." - (declare (indent 1)) - (let* ((type-str (symbol-name type)) - (prefix (concat "guix-" type-str)) - (group (intern prefix)) - (faces-group (intern (concat prefix "-faces")))) - (guix-keyword-args-let args - ((parent-group :parent-group 'guix) - (parent-faces-group :parent-faces-group 'guix-faces) - (group-doc :group-doc - (format "Settings for '%s' buffers." - type-str)) - (faces-group-doc :faces-group-doc - (format "Faces for '%s' buffers." - type-str))) - `(progn - (defgroup ,group nil - ,group-doc - :group ',parent-group) - - (defgroup ,faces-group nil - ,faces-group-doc - :group ',group - :group ',parent-faces-group))))) - -(defmacro guix-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -See `guix-define-groups'." - (declare (indent 1)) - `(guix-define-groups ,entry-type - ,@args)) - -(defmacro guix-define-buffer-type (buffer-type &rest args) - "Define general code for BUFFER-TYPE. -See `guix-define-groups'." - (declare (indent 1)) - `(guix-define-groups ,buffer-type - ,@args)) - -(defmacro guix-buffer-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... -In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. - -Required keywords: - - - `:buffer-name' - default value of the generated - `guix-TYPE-buffer-name' variable. - - - `:get-entries-function' - default value of the generated - `guix-TYPE-get-function' variable. - - - `:show-entries-function' - default value of the generated - `guix-TYPE-show-function' variable. - - Alternatively, if `:show-entries-function' is not specified, a - default `guix-TYPE-show-entries' will be generated, and the - following keyword should be specified instead: - - - `:insert-entries-function' - default value of the generated - `guix-TYPE-insert-function' variable. - -Optional keywords: - - - `:message-function' - default value of the generated - `guix-TYPE-message-function' variable. - - - `:titles' - default value of the generated - `guix-TYPE-titles' variable. - - - `:history-size' - default value of the generated - `guix-TYPE-history-size' variable. - - - `:revert-confirm?' - default value of the generated - `guix-TYPE-revert-confirm' variable. - - - `:mode-name' - name (a string appeared in the mode-line) of - the generated `guix-TYPE-mode'. - - - `:mode-init-function' - default value of the generated - `guix-TYPE-mode-initialize-function' variable. - - - `:reduced?' - if non-nil, generate only group, faces group - and titles variable (if specified); all keywords become - optional." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (prefix (concat "guix-" entry-type-str "-" - buffer-type-str)) - (group (intern prefix)) - (faces-group (intern (concat prefix "-faces"))) - (get-entries-var (intern (concat prefix "-get-function"))) - (show-entries-var (intern (concat prefix "-show-function"))) - (show-entries-fun (intern (concat prefix "-show-entries"))) - (message-var (intern (concat prefix "-message-function"))) - (buffer-name-var (intern (concat prefix "-buffer-name"))) - (titles-var (intern (concat prefix "-titles"))) - (history-size-var (intern (concat prefix "-history-size"))) - (revert-confirm-var (intern (concat prefix "-revert-confirm")))) - (guix-keyword-args-let args - ((get-entries-val :get-entries-function) - (show-entries-val :show-entries-function) - (insert-entries-val :insert-entries-function) - (mode-name :mode-name (capitalize prefix)) - (mode-init-val :mode-init-function) - (message-val :message-function) - (buffer-name-val :buffer-name) - (titles-val :titles) - (history-size-val :history-size 20) - (revert-confirm-val :revert-confirm? t) - (reduced? :reduced?)) - `(progn - (defgroup ,group nil - ,(format "Displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str) - :group ',(intern (concat "guix-" entry-type-str)) - :group ',(intern (concat "guix-" buffer-type-str))) - - (defgroup ,faces-group nil - ,(format "Faces for displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str) - :group ',group - :group ',(intern (concat "guix-" entry-type-str "-faces")) - :group ',(intern (concat "guix-" buffer-type-str "-faces"))) - - (defcustom ,titles-var ,titles-val - ,(format "Alist of titles of '%s' parameters." - entry-type-str) - :type '(alist :key-type symbol :value-type string) - :group ',group) - - ,(unless reduced? - `(progn - (defvar ,get-entries-var ,get-entries-val - ,(format "\ -Function used to receive '%s' entries for '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,show-entries-var - ,(or show-entries-val `',show-entries-fun) - ,(format "\ -Function used to show '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,message-var ,message-val - ,(format "\ -Function used to display a message after showing '%s' entries. -If nil, do not display messages." - entry-type-str)) - - (defcustom ,buffer-name-var ,buffer-name-val - ,(format "\ -Default name of '%s' buffer for displaying '%s' entries. -May be a string or a function returning a string. The function -is called with the same arguments as `%S'." - buffer-type-str entry-type-str get-entries-var) - :type '(choice string function) - :group ',group) - - (defcustom ,history-size-var ,history-size-val - ,(format "\ -Maximum number of items saved in history of `%S' buffer. -If 0, the history is disabled." - buffer-name-var) - :type 'integer - :group ',group) - - (defcustom ,revert-confirm-var ,revert-confirm-val - ,(format "\ -If non-nil, ask to confirm for reverting `%S' buffer." - buffer-name-var) - :type 'boolean - :group ',group) - - (guix-alist-put! - '((get-entries . ,get-entries-var) - (show-entries . ,show-entries-var) - (message . ,message-var) - (buffer-name . ,buffer-name-var) - (history-size . ,history-size-var) - (revert-confirm . ,revert-confirm-var)) - 'guix-buffer-data ',buffer-type ',entry-type) - - ,(unless show-entries-val - `(defun ,show-entries-fun (entries) - ,(format "\ -Show '%s' ENTRIES in the current '%s' buffer." - entry-type-str buffer-type-str) - (guix-buffer-show-entries-default - entries ',buffer-type ',entry-type))) - - ,(when (or insert-entries-val - (null show-entries-val)) - (let ((insert-entries-var - (intern (concat prefix "-insert-function")))) - `(progn - (defvar ,insert-entries-var ,insert-entries-val - ,(format "\ -Function used to print '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (guix-alist-put! - ',insert-entries-var 'guix-buffer-data - ',buffer-type ',entry-type - 'insert-entries)))) - - ,(when (or mode-name - mode-init-val - (null show-entries-val)) - (let* ((mode-str (concat prefix "-mode")) - (mode-map-str (concat mode-str "-map")) - (mode (intern mode-str)) - (parent-mode (intern - (concat "guix-" buffer-type-str - "-mode"))) - (mode-var (intern - (concat mode-str "-function"))) - (mode-init-var (intern - (concat mode-str - "-initialize-function")))) - `(progn - (defvar ,mode-var ',mode - ,(format "\ -Major mode for displaying '%s' entries in '%s' buffer." - entry-type-str buffer-type-str)) - - (defvar ,mode-init-var ,mode-init-val - ,(format "\ -Function used to set up '%s' buffer for displaying '%s' entries." - buffer-type-str entry-type-str)) - - (define-derived-mode ,mode ,parent-mode ,mode-name - ,(format "\ -Major mode for displaying '%s' entries in '%s' buffer. - -\\{%s}" - entry-type-str buffer-type-str mode-map-str) - (setq-local revert-buffer-function - 'guix-buffer-revert) - (setq-local guix-history-size - (guix-buffer-history-size - ',buffer-type ',entry-type)) - (guix-buffer-mode-initialize - ',buffer-type ',entry-type)) - - (guix-alist-put! - ',mode-var 'guix-buffer-data - ',buffer-type ',entry-type 'mode) - (guix-alist-put! - ',mode-init-var 'guix-buffer-data - ',buffer-type ',entry-type - 'mode-init)))))) - - (guix-alist-put! - ',titles-var 'guix-buffer-data - ',buffer-type ',entry-type 'titles))))) - - -(defvar guix-buffer-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-buffer-with-item" - "guix-buffer-with-current-item" - "guix-buffer-define-interface" - "guix-define-groups" - "guix-define-entry-type" - "guix-define-buffer-type")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-buffer-font-lock-keywords) - -(provide 'guix-buffer) - -;;; guix-buffer.el ends here diff --git a/emacs/guix-build-log.el b/emacs/guix-build-log.el deleted file mode 100644 index f67be16326..0000000000 --- a/emacs/guix-build-log.el +++ /dev/null @@ -1,381 +0,0 @@ -;;; guix-build-log.el --- Major and minor modes for build logs -*- 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 major mode (`guix-build-log-mode') and a minor mode -;; (`guix-build-log-minor-mode') for highlighting Guix build logs. - -;;; Code: - -(require 'guix-utils) - -(defgroup guix-build-log nil - "Settings for `guix-build-log-mode'." - :group 'guix) - -(defgroup guix-build-log-faces nil - "Faces for `guix-build-log-mode'." - :group 'guix-build-log - :group 'guix-faces) - -(defface guix-build-log-title-head - '((t :inherit font-lock-keyword-face)) - "Face for '@' symbol of a log title." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-start - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting a start of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-success - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting a successful end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-fail - '((t :inherit error)) - "Face for a log title denoting a failed end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-title-end - '((t :inherit guix-build-log-title-head)) - "Face for a log title denoting an undefined end of a process." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-name - '((t :inherit font-lock-function-name-face)) - "Face for a phase name." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-start - '((default :weight bold) - (((class grayscale) (background light)) :foreground "Gray90") - (((class grayscale) (background dark)) :foreground "DimGray") - (((class color) (min-colors 16) (background light)) - :foreground "DarkGreen") - (((class color) (min-colors 16) (background dark)) - :foreground "LimeGreen") - (((class color) (min-colors 8)) :foreground "green")) - "Face for the start line of a phase." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-end - '((((class grayscale) (background light)) :foreground "Gray90") - (((class grayscale) (background dark)) :foreground "DimGray") - (((class color) (min-colors 16) (background light)) - :foreground "ForestGreen") - (((class color) (min-colors 16) (background dark)) - :foreground "LightGreen") - (((class color) (min-colors 8)) :foreground "green") - (t :weight bold)) - "Face for the end line of a phase." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-success - '((t)) - "Face for the 'succeeded' word of a phase line." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-fail - '((t :inherit error)) - "Face for the 'failed' word of a phase line." - :group 'guix-build-log-faces) - -(defface guix-build-log-phase-seconds - '((t :inherit font-lock-constant-face)) - "Face for the number of seconds for a phase." - :group 'guix-build-log-faces) - -(defcustom guix-build-log-minor-mode-activate t - "If non-nil, then `guix-build-log-minor-mode' is automatically -activated in `shell-mode' buffers." - :type 'boolean - :group 'guix-build-log) - -(defcustom guix-build-log-mode-hook '() - "Hook run after `guix-build-log-mode' is entered." - :type 'hook - :group 'guix-build-log) - -(defvar guix-build-log-phase-name-regexp "`\\([^']+\\)'" - "Regexp for a phase name.") - -(defvar guix-build-log-phase-start-regexp - (concat "^starting phase " guix-build-log-phase-name-regexp) - "Regexp for the start line of a 'build' phase.") - -(defun guix-build-log-title-regexp (&optional state) - "Return regexp for the log title. -STATE is a symbol denoting a state of the title. It should be -`start', `fail', `success' or `nil' (for a regexp matching any -state)." - (let* ((word-rx (rx (1+ (any word "-")))) - (state-rx (cond ((eq state 'start) (concat word-rx "started")) - ((eq state 'success) (concat word-rx "succeeded")) - ((eq state 'fail) (concat word-rx "failed")) - (t word-rx)))) - (rx-to-string - `(and bol (group "@") " " (group (regexp ,state-rx))) - t))) - -(defun guix-build-log-phase-end-regexp (&optional state) - "Return regexp for the end line of a 'build' phase. -STATE is a symbol denoting how a build phase was ended. It should be -`fail', `success' or `nil' (for a regexp matching any state)." - (let ((state-rx (cond ((eq state 'success) "succeeded") - ((eq state 'fail) "failed") - (t (regexp-opt '("succeeded" "failed")))))) - (rx-to-string - `(and bol "phase " (regexp ,guix-build-log-phase-name-regexp) - " " (group (regexp ,state-rx)) " after " - (group (1+ (or digit "."))) " seconds") - t))) - -(defvar guix-build-log-phase-end-regexp - ;; For efficiency, it is better to have a regexp for the general line - ;; of the phase end, then to call the function all the time. - (guix-build-log-phase-end-regexp) - "Regexp for the end line of a 'build' phase.") - -(defvar guix-build-log-font-lock-keywords - `((,(guix-build-log-title-regexp 'start) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-start)) - (,(guix-build-log-title-regexp 'success) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-success)) - (,(guix-build-log-title-regexp 'fail) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-fail)) - (,(guix-build-log-title-regexp) - (1 'guix-build-log-title-head) - (2 'guix-build-log-title-end)) - (,guix-build-log-phase-start-regexp - (0 'guix-build-log-phase-start) - (1 'guix-build-log-phase-name prepend)) - (,(guix-build-log-phase-end-regexp 'success) - (0 'guix-build-log-phase-end) - (1 'guix-build-log-phase-name prepend) - (2 'guix-build-log-phase-success prepend) - (3 'guix-build-log-phase-seconds prepend)) - (,(guix-build-log-phase-end-regexp 'fail) - (0 'guix-build-log-phase-end) - (1 'guix-build-log-phase-name prepend) - (2 'guix-build-log-phase-fail prepend) - (3 'guix-build-log-phase-seconds prepend))) - "A list of `font-lock-keywords' for `guix-build-log-mode'.") - -(defvar guix-build-log-common-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M-n") 'guix-build-log-next-phase) - (define-key map (kbd "M-p") 'guix-build-log-previous-phase) - (define-key map (kbd "TAB") 'guix-build-log-phase-toggle) - (define-key map (kbd "<tab>") 'guix-build-log-phase-toggle) - (define-key map (kbd "<backtab>") 'guix-build-log-phase-toggle-all) - (define-key map [(shift tab)] 'guix-build-log-phase-toggle-all) - map) - "Parent keymap for 'build-log' buffers. -For `guix-build-log-mode' this map is used as is. -For `guix-build-log-minor-mode' this map is prefixed with 'C-c'.") - -(defvar guix-build-log-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap (list guix-build-log-common-map) - special-mode-map)) - (define-key map (kbd "c") 'compilation-shell-minor-mode) - (define-key map (kbd "v") 'view-mode) - map) - "Keymap for `guix-build-log-mode' buffers.") - -(defvar guix-build-log-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c") guix-build-log-common-map) - map) - "Keymap for `guix-build-log-minor-mode' buffers.") - -(defun guix-build-log-phase-start (&optional with-header?) - "Return the start point of the current build phase. -If WITH-HEADER? is non-nil, do not skip 'starting phase ...' header. -Return nil, if there is no phase start before the current point." - (save-excursion - (end-of-line) - (when (re-search-backward guix-build-log-phase-start-regexp nil t) - (unless with-header? (end-of-line)) - (point)))) - -(defun guix-build-log-phase-end () - "Return the end point of the current build phase." - (save-excursion - (beginning-of-line) - (when (re-search-forward guix-build-log-phase-end-regexp nil t) - (point)))) - -(defun guix-build-log-phase-hide () - "Hide the body of the current build phase." - (interactive) - (let ((beg (guix-build-log-phase-start)) - (end (guix-build-log-phase-end))) - (when (and beg end) - ;; If not on the header line, move to it. - (when (and (> (point) beg) - (< (point) end)) - (goto-char (guix-build-log-phase-start t))) - (remove-overlays beg end 'invisible t) - (let ((o (make-overlay beg end))) - (overlay-put o 'evaporate t) - (overlay-put o 'invisible t))))) - -(defun guix-build-log-phase-show () - "Show the body of the current build phase." - (interactive) - (let ((beg (guix-build-log-phase-start)) - (end (guix-build-log-phase-end))) - (when (and beg end) - (remove-overlays beg end 'invisible t)))) - -(defun guix-build-log-phase-hidden-p () - "Return non-nil, if the body of the current build phase is hidden." - (let ((beg (guix-build-log-phase-start))) - (and beg - (cl-some (lambda (o) - (overlay-get o 'invisible)) - (overlays-at beg))))) - -(defun guix-build-log-phase-toggle-function () - "Return a function to toggle the body of the current build phase." - (if (guix-build-log-phase-hidden-p) - #'guix-build-log-phase-show - #'guix-build-log-phase-hide)) - -(defun guix-build-log-phase-toggle () - "Show/hide the body of the current build phase." - (interactive) - (funcall (guix-build-log-phase-toggle-function))) - -(defun guix-build-log-phase-toggle-all () - "Show/hide the bodies of all build phases." - (interactive) - (save-excursion - ;; Some phases may be hidden, and some shown. Whether to hide or to - ;; show them, it is determined by the state of the first phase here. - (goto-char (point-min)) - (let ((fun (save-excursion - (re-search-forward guix-build-log-phase-start-regexp nil t) - (guix-build-log-phase-toggle-function)))) - (while (re-search-forward guix-build-log-phase-start-regexp nil t) - (funcall fun))))) - -(defun guix-build-log-next-phase (&optional arg) - "Move to the next build phase. -With ARG, do it that many times. Negative ARG means move -backward." - (interactive "^p") - (if arg - (when (zerop arg) (user-error "Try again")) - (setq arg 1)) - (let ((search-fun (if (> arg 0) - #'re-search-forward - #'re-search-backward)) - (n (abs arg)) - found last-found) - (save-excursion - (end-of-line (if (> arg 0) 1 0)) ; skip the current line - (while (and (not (zerop n)) - (setq found - (funcall search-fun - guix-build-log-phase-start-regexp - nil t))) - (setq n (1- n) - last-found found))) - (when last-found - (goto-char last-found) - (forward-line 0)) - (or found - (user-error (if (> arg 0) - "No next build phase" - "No previous build phase"))))) - -(defun guix-build-log-previous-phase (&optional arg) - "Move to the previous build phase. -With ARG, do it that many times. Negative ARG means move -forward." - (interactive "^p") - (guix-build-log-next-phase (- (or arg 1)))) - -;;;###autoload -(define-derived-mode guix-build-log-mode special-mode - "Guix-Build-Log" - "Major mode for viewing Guix build logs. - -\\{guix-build-log-mode-map}" - (setq font-lock-defaults '(guix-build-log-font-lock-keywords t))) - -;;;###autoload -(define-minor-mode guix-build-log-minor-mode - "Toggle Guix Build Log minor mode. - -With a prefix argument ARG, enable Guix Build Log minor mode if -ARG is positive, and disable it otherwise. If called from Lisp, -enable the mode if ARG is omitted or nil. - -When Guix Build Log minor mode is enabled, it highlights build -log in the current buffer. This mode can be enabled -programmatically using hooks: - - (add-hook 'shell-mode-hook 'guix-build-log-minor-mode) - -\\{guix-build-log-minor-mode-map}" - :init-value nil - :lighter " Guix-Build-Log" - :keymap guix-build-log-minor-mode-map - :group 'guix-build-log - (if guix-build-log-minor-mode - (font-lock-add-keywords nil guix-build-log-font-lock-keywords) - (font-lock-remove-keywords nil guix-build-log-font-lock-keywords)) - (when font-lock-mode - (font-lock-fontify-buffer))) - -;;;###autoload -(defun guix-build-log-minor-mode-activate-maybe () - "Activate `guix-build-log-minor-mode' depending on -`guix-build-log-minor-mode-activate' variable." - (when guix-build-log-minor-mode-activate - (guix-build-log-minor-mode))) - -(defun guix-build-log-find-file (file-or-url) - "Open FILE-OR-URL in `guix-build-log-mode'." - (guix-find-file-or-url file-or-url) - (guix-build-log-mode)) - -;;;###autoload -(add-hook 'shell-mode-hook 'guix-build-log-minor-mode-activate-maybe) - -;;;###autoload -(add-to-list 'auto-mode-alist - ;; Regexp for log files (usually placed in /var/log/guix/...) - (cons (rx "/guix/drvs/" (= 2 alnum) "/" (= 30 alnum) - "-" (+ (any alnum "-+.")) ".drv" string-end) - 'guix-build-log-mode)) - -(provide 'guix-build-log) - -;;; guix-build-log.el ends here diff --git a/emacs/guix-command.el b/emacs/guix-command.el deleted file mode 100644 index 7069c51649..0000000000 --- a/emacs/guix-command.el +++ /dev/null @@ -1,830 +0,0 @@ -;;; guix-command.el --- Popup interface for guix commands -*- lexical-binding: t -*- - -;; Copyright © 2015, 2016 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) -(require 'guix-build-log) -(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 - '(("container" :char ?C) - ("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) - ("--rounds" :char ?R :fun read-number) - ("--with-input" :char ?W))) - -(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) - ("--file" :fun guix-read-file-name) - ("--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 - '(("--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-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) - ("--profile" :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) - ("--type" :fun guix-read-refresh-updater-names-string) - ("--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 - '(("disk-image" :char ?D) - ("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" "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")) - (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")))))) - -(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))) - (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 -;; 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)) - - -;;; 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 (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))))) - - -;;; '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 - (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" "shepherd-graph") ,graph-arg) - (("system" "extension-graph") ,graph-arg))) - "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)) - (("system" "shepherd-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'.") - -(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 - (cl-list* (car args) "--log-file" (cdr args)))) - (output (guix-command-output args)) - (files (split-string output "\n" t))) - (dolist (file files) - (guix-build-log-find-file file)))) - -(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 - (cl-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 - ',commands 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 diff --git a/emacs/guix-config.el.in b/emacs/guix-config.el.in deleted file mode 100644 index c09c2fe86a..0000000000 --- a/emacs/guix-config.el.in +++ /dev/null @@ -1,44 +0,0 @@ -;;; guix-config.el --- Compile-time configuration of Guix. - -;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> -;; Copyright © 2015, 2016 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/>. - -;;; Code: - -(defconst guix-config-name "@PACKAGE_NAME@" - "Guix full name.") - -(defconst guix-config-version "@PACKAGE_VERSION@" - "Guix version.") - -(defconst guix-config-emacs-interface-directory - (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@")) - -(defconst guix-config-state-directory - ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) - -(defconst guix-config-guile-program "@GUILE@" - "Name of the 'guile' executable defined at configure time.") - -(defconst guix-config-dot-program "@DOT_USER_PROGRAM@" - "Name of the 'dot' executable defined at configure time.") - -(provide 'guix-config) - -;;; guix-config.el ends here diff --git a/emacs/guix-devel.el b/emacs/guix-devel.el deleted file mode 100644 index b71670cdfb..0000000000 --- a/emacs/guix-devel.el +++ /dev/null @@ -1,382 +0,0 @@ -;;; guix-devel.el --- Development tools -*- 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 commands useful for developing Guix (or even -;; arbitrary Guile code) with Geiser. - -;;; Code: - -(require 'lisp-mode) -(require 'guix-guile) -(require 'guix-geiser) -(require 'guix-utils) -(require 'guix-base) - -(defgroup guix-devel nil - "Settings for Guix development utils." - :group 'guix) - -(defgroup guix-devel-faces nil - "Faces for `guix-devel-mode'." - :group 'guix-devel - :group 'guix-faces) - -(defface guix-devel-modify-phases-keyword - '((t :inherit font-lock-preprocessor-face)) - "Face for a `modify-phases' keyword ('delete', 'replace', etc.)." - :group 'guix-devel-faces) - -(defface guix-devel-gexp-symbol - '((t :inherit font-lock-keyword-face)) - "Face for gexp symbols ('#~', '#$', etc.). -See Info node `(guix) G-Expressions'." - :group 'guix-devel-faces) - -(defcustom guix-devel-activate-mode t - "If non-nil, then `guix-devel-mode' is automatically activated -in Scheme buffers." - :type 'boolean - :group 'guix-devel) - -(defun guix-devel-use-modules (&rest modules) - "Use guile MODULES." - (apply #'guix-geiser-call "use-modules" modules)) - -(defun guix-devel-use-module (&optional module) - "Use guile MODULE in the current Geiser REPL. -MODULE is a string with the module name - e.g., \"(ice-9 match)\". -Interactively, use the module defined by the current scheme file." - (interactive (list (guix-guile-current-module))) - (guix-devel-use-modules module) - (message "Using %s module." module)) - -(defun guix-devel-copy-module-as-kill () - "Put the name of the current guile module into `kill-ring'." - (interactive) - (guix-copy-as-kill (guix-guile-current-module))) - -(defun guix-devel-setup-repl (&optional repl) - "Setup REPL for using `guix-devel-...' commands." - (guix-devel-use-modules "(guix monad-repl)" - "(guix scripts)" - "(guix store)" - "(guix ui)") - ;; Without this workaround, the warning/build output disappears. See - ;; <https://github.com/jaor/geiser/issues/83> for details. - (guix-geiser-eval-in-repl-synchronously - "(begin - (guix-warning-port (current-warning-port)) - (current-build-output-port (current-error-port)))" - repl 'no-history 'no-display)) - -(defvar guix-devel-repl-processes nil - "List of REPL processes configured by `guix-devel-setup-repl'.") - -(defun guix-devel-setup-repl-maybe (&optional repl) - "Setup (if needed) REPL for using `guix-devel-...' commands." - (let ((process (get-buffer-process (or repl (guix-geiser-repl))))) - (when (and process - (not (memq process guix-devel-repl-processes))) - (guix-devel-setup-repl repl) - (push process guix-devel-repl-processes)))) - -(defmacro guix-devel-with-definition (def-var &rest body) - "Run BODY with the current guile definition bound to DEF-VAR. -Bind DEF-VAR variable to the name of the current top-level -definition, setup the current REPL, use the current module, and -run BODY." - (declare (indent 1) (debug (symbolp body))) - `(let ((,def-var (guix-guile-current-definition))) - (guix-devel-setup-repl-maybe) - (guix-devel-use-modules (guix-guile-current-module)) - ,@body)) - -(defun guix-devel-build-package-definition () - "Build a package defined by the current top-level variable definition." - (interactive) - (guix-devel-with-definition def - (when (or (not guix-operation-confirm) - (guix-operation-prompt (format "Build '%s'?" def))) - (guix-geiser-eval-in-repl - (concat ",run-in-store " - (guix-guile-make-call-expression - "build-package" def - "#:use-substitutes?" (guix-guile-boolean - guix-use-substitutes) - "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) - -(defun guix-devel-build-package-source () - "Build the source of the current package definition." - (interactive) - (guix-devel-with-definition def - (when (or (not guix-operation-confirm) - (guix-operation-prompt - (format "Build '%s' package source?" def))) - (guix-geiser-eval-in-repl - (concat ",run-in-store " - (guix-guile-make-call-expression - "build-package-source" def - "#:use-substitutes?" (guix-guile-boolean - guix-use-substitutes) - "#:dry-run?" (guix-guile-boolean guix-dry-run))))))) - -(defun guix-devel-lint-package () - "Check the current package. -See Info node `(guix) Invoking guix lint' for details." - (interactive) - (guix-devel-with-definition def - (guix-devel-use-modules "(guix scripts lint)") - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Lint '%s' package?" def))) - (guix-geiser-eval-in-repl - (format "(run-checkers %s)" def))))) - - -;;; Font-lock - -(defvar guix-devel-modify-phases-keyword-regexp - (rx (+ word)) - "Regexp for a 'modify-phases' keyword ('delete', 'replace', etc.).") - -(defun guix-devel-modify-phases-font-lock-matcher (limit) - "Find a 'modify-phases' keyword. -This function is used as a MATCHER for `font-lock-keywords'." - (ignore-errors - (down-list) - (or (re-search-forward guix-devel-modify-phases-keyword-regexp - limit t) - (set-match-data nil)) - (up-list) - t)) - -(defun guix-devel-modify-phases-font-lock-pre () - "Skip the next sexp, and return the end point of the current list. -This function is used as a PRE-MATCH-FORM for `font-lock-keywords' -to find 'modify-phases' keywords." - (let ((in-comment? (nth 4 (syntax-ppss)))) - ;; If 'modify-phases' is commented, do not try to search for its - ;; keywords. - (unless in-comment? - (ignore-errors (forward-sexp)) - (save-excursion (up-list) (point))))) - -(defconst guix-devel-keywords - '("call-with-compressed-output-port" - "call-with-container" - "call-with-decompressed-port" - "call-with-derivation-narinfo" - "call-with-derivation-substitute" - "call-with-error-handling" - "call-with-temporary-directory" - "call-with-temporary-output-file" - "define-enumerate-type" - "define-gexp-compiler" - "define-lift" - "define-monad" - "define-operation" - "define-record-type*" - "emacs-substitute-sexps" - "emacs-substitute-variables" - "mbegin" - "mlet" - "mlet*" - "modify-services" - "munless" - "mwhen" - "run-with-state" - "run-with-store" - "signature-case" - "substitute*" - "substitute-keyword-arguments" - "test-assertm" - "use-package-modules" - "use-service-modules" - "use-system-modules" - "with-atomic-file-output" - "with-atomic-file-replacement" - "with-derivation-narinfo" - "with-derivation-substitute" - "with-directory-excursion" - "with-error-handling" - "with-imported-modules" - "with-monad" - "with-mutex" - "with-store")) - -(defvar guix-devel-font-lock-keywords - `((,(rx (or "#~" "#$" "#$@" "#+" "#+@")) . - 'guix-devel-gexp-symbol) - (,(guix-guile-keyword-regexp (regexp-opt guix-devel-keywords)) - (1 'font-lock-keyword-face)) - (,(guix-guile-keyword-regexp "modify-phases") - (1 'font-lock-keyword-face) - (guix-devel-modify-phases-font-lock-matcher - (guix-devel-modify-phases-font-lock-pre) - nil - (0 'guix-devel-modify-phases-keyword nil t)))) - "A list of `font-lock-keywords' for `guix-devel-mode'.") - - -;;; Indentation - -(defmacro guix-devel-scheme-indent (&rest rules) - "Set `scheme-indent-function' according to RULES. -Each rule should have a form (SYMBOL VALUE). See `put' for details." - (declare (indent 0)) - `(progn - ,@(mapcar (lambda (rule) - `(put ',(car rule) 'scheme-indent-function ,(cadr rule))) - rules))) - -(defun guix-devel-indent-package (state indent-point normal-indent) - "Indentation rule for 'package' form." - (let* ((package-eol (line-end-position)) - (count (if (and (ignore-errors (down-list) t) - (< (point) package-eol) - (looking-at "inherit\\>")) - 1 - 0))) - (lisp-indent-specform count state indent-point normal-indent))) - -(defun guix-devel-indent-modify-phases-keyword (count) - "Return indentation function for 'modify-phases' keywords." - (lambda (state indent-point normal-indent) - (when (ignore-errors - (goto-char (nth 1 state)) ; start of keyword sexp - (backward-up-list) - (looking-at "(modify-phases\\>")) - (lisp-indent-specform count state indent-point normal-indent)))) - -(defalias 'guix-devel-indent-modify-phases-keyword-1 - (guix-devel-indent-modify-phases-keyword 1)) -(defalias 'guix-devel-indent-modify-phases-keyword-2 - (guix-devel-indent-modify-phases-keyword 2)) - -(guix-devel-scheme-indent - (bag 0) - (build-system 0) - (call-with-compressed-output-port 2) - (call-with-container 1) - (call-with-decompressed-port 2) - (call-with-error-handling 0) - (container-excursion 1) - (emacs-batch-edit-file 1) - (emacs-batch-eval 0) - (emacs-substitute-sexps 1) - (emacs-substitute-variables 1) - (file-system 0) - (graft 0) - (manifest-entry 0) - (manifest-pattern 0) - (mbegin 1) - (mlet 2) - (mlet* 2) - (modify-phases 1) - (modify-services 1) - (munless 1) - (mwhen 1) - (operating-system 0) - (origin 0) - (package 'guix-devel-indent-package) - (run-with-state 1) - (run-with-store 1) - (signature-case 1) - (substitute* 1) - (substitute-keyword-arguments 1) - (test-assertm 1) - (with-atomic-file-output 1) - (with-derivation-narinfo 1) - (with-derivation-substitute 2) - (with-directory-excursion 1) - (with-error-handling 0) - (with-imported-modules 1) - (with-monad 1) - (with-mutex 1) - (with-store 1) - (wrap-program 1) - - ;; 'modify-phases' keywords: - (replace 'guix-devel-indent-modify-phases-keyword-1) - (add-after 'guix-devel-indent-modify-phases-keyword-2) - (add-before 'guix-devel-indent-modify-phases-keyword-2)) - - -(defvar guix-devel-keys-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "b") 'guix-devel-build-package-definition) - (define-key map (kbd "s") 'guix-devel-build-package-source) - (define-key map (kbd "l") 'guix-devel-lint-package) - (define-key map (kbd "k") 'guix-devel-copy-module-as-kill) - (define-key map (kbd "u") 'guix-devel-use-module) - map) - "Keymap with subkeys for `guix-devel-mode-map'.") - -(defvar guix-devel-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c .") guix-devel-keys-map) - map) - "Keymap for `guix-devel-mode'.") - -;;;###autoload -(define-minor-mode guix-devel-mode - "Minor mode for `scheme-mode' buffers. - -With a prefix argument ARG, enable the mode if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. - -When Guix Devel mode is enabled, it provides the following key -bindings: - -\\{guix-devel-mode-map}" - :init-value nil - :lighter " Guix" - :keymap guix-devel-mode-map - (if guix-devel-mode - (progn - (setq-local font-lock-multiline t) - (font-lock-add-keywords nil guix-devel-font-lock-keywords)) - (setq-local font-lock-multiline nil) - (font-lock-remove-keywords nil guix-devel-font-lock-keywords)) - (when font-lock-mode - (font-lock-fontify-buffer))) - -;;;###autoload -(defun guix-devel-activate-mode-maybe () - "Activate `guix-devel-mode' depending on -`guix-devel-activate-mode' variable." - (when guix-devel-activate-mode - (guix-devel-mode))) - -;;;###autoload -(add-hook 'scheme-mode-hook 'guix-devel-activate-mode-maybe) - - -(defvar guix-devel-emacs-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-devel-with-definition") symbol-end) . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode - guix-devel-emacs-font-lock-keywords) - -(provide 'guix-devel) - -;;; guix-devel.el ends here diff --git a/emacs/guix-entry.el b/emacs/guix-entry.el deleted file mode 100644 index 5eed2ed015..0000000000 --- a/emacs/guix-entry.el +++ /dev/null @@ -1,59 +0,0 @@ -;;; guix-entry.el --- 'Entry' type -*- 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 an API for 'entry' type which is just an alist of -;; KEY/VALUE pairs (KEY should be a symbol) with the required 'id' KEY. - -;;; Code: - -(require 'cl-lib) -(require 'guix-utils) - -(defalias 'guix-entry-value #'guix-assq-value) - -(defun guix-entry-id (entry) - "Return ENTRY ID." - (guix-entry-value entry 'id)) - -(defun guix-entry-by-id (id entries) - "Return an entry from ENTRIES by its ID." - (cl-find-if (lambda (entry) - (equal (guix-entry-id entry) id)) - entries)) - -(defun guix-entries-by-ids (ids entries) - "Return entries with IDS (a list of identifiers) from ENTRIES." - (cl-remove-if-not (lambda (entry) - (member (guix-entry-id entry) ids)) - entries)) - -(defun guix-replace-entry (id new-entry entries) - "Replace an entry with ID from ENTRIES by NEW-ENTRY. -Return a list of entries with the replaced entry." - (cl-substitute-if new-entry - (lambda (entry) - (equal id (guix-entry-id entry))) - entries - :count 1)) - -(provide 'guix-entry) - -;;; guix-entry.el ends here diff --git a/emacs/guix-external.el b/emacs/guix-external.el deleted file mode 100644 index f571ffd845..0000000000 --- a/emacs/guix-external.el +++ /dev/null @@ -1,88 +0,0 @@ -;;; guix-external.el --- External programs -*- 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 auxiliary code for running external programs. - -;;; Code: - -(require 'cl-lib) -(require 'guix-config) - -(defgroup guix-external nil - "Settings for external programs." - :group 'guix) - -(defcustom guix-guile-program guix-config-guile-program - "Name of the 'guile' executable used for Guix REPL. -May be either a string (the name of the executable) or a list of -strings of the form: - - (NAME . ARGS) - -Where ARGS is a list of arguments to the guile program." - :type 'string - :group 'guix-external) - -(defcustom guix-dot-program - (if (file-name-absolute-p guix-config-dot-program) - guix-config-dot-program - (executable-find "dot")) - "Name of the 'dot' executable." - :type 'string - :group 'guix-external) - -(defcustom guix-dot-default-arguments - '("-Tpng") - "Default arguments for 'dot' program." - :type '(repeat string) - :group 'guix-external) - -(defcustom guix-dot-file-name-function #'guix-png-file-name - "Function used to define a file name of a temporary 'dot' file. -The function is called without arguments." - :type '(choice (function-item guix-png-file-name) - (function :tag "Other function")) - :group 'guix-external) - -(defun guix-dot-arguments (output-file &rest args) - "Return a list of dot arguments for writing a graph into OUTPUT-FILE. -If ARGS is nil, use `guix-dot-default-arguments'." - (or guix-dot-program - (error (concat "Couldn't find 'dot'.\n" - "Set guix-dot-program to a proper value"))) - (cl-list* guix-dot-program - (concat "-o" output-file) - (or args guix-dot-default-arguments))) - -(defun guix-dot-file-name () - "Call `guix-dot-file-name-function'." - (funcall guix-dot-file-name-function)) - -(defun guix-png-file-name () - "Return '.png' file name in the `temporary-file-directory'." - (concat (make-temp-name - (concat (file-name-as-directory temporary-file-directory) - "guix-emacs-graph-")) - ".png")) - -(provide 'guix-external) - -;;; guix-external.el ends here diff --git a/emacs/guix-geiser.el b/emacs/guix-geiser.el deleted file mode 100644 index 833f5bb2b3..0000000000 --- a/emacs/guix-geiser.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; guix-geiser.el --- Interacting with Geiser -*- 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 functions to evaluate guile code using Geiser. - -;;; Code: - -(require 'geiser-mode) -(require 'guix-guile) - -(defun guix-geiser-repl () - "Return the current Geiser REPL." - (or geiser-repl--repl - (geiser-repl--repl/impl 'guile) - (error "Geiser REPL not found"))) - -(defun guix-geiser-eval (str &optional repl) - "Evaluate STR with guile expression using Geiser REPL. -If REPL is nil, use the current Geiser REPL. -Return a list of strings with result values of evaluation." - (with-current-buffer (or repl (guix-geiser-repl)) - (let ((res (geiser-eval--send/wait `(:eval (:scm ,str))))) - (if (geiser-eval--retort-error res) - (error "Error in evaluating guile expression: %s" - (geiser-eval--retort-output res)) - (cdr (assq 'result res)))))) - -(defun guix-geiser-eval-read (str &optional repl) - "Evaluate STR with guile expression using Geiser REPL. -Return elisp expression of the first result value of evaluation." - ;; The goal is to convert a string with scheme expression into elisp - ;; expression. - (let ((result (car (guix-geiser-eval str repl)))) - (cond - ((or (string= result "#f") - (string= result "#<unspecified>")) - nil) - ((string= result "#t") - t) - (t - (read (replace-regexp-in-string - "[ (]\\(#f\\)" "nil" - (replace-regexp-in-string - "[ (]\\(#t\\)" "t" - result - nil nil 1) - nil nil 1)))))) - -(defun guix-repl-send (cmd &optional save-history) - "Send CMD input string to the current REPL buffer. -This is the same as `geiser-repl--send', but with SAVE-HISTORY -argument. If SAVE-HISTORY is non-nil, save CMD in the REPL -history." - (when (and cmd (eq major-mode 'geiser-repl-mode)) - (geiser-repl--prepare-send) - (goto-char (point-max)) - (comint-kill-input) - (insert cmd) - (let ((comint-input-filter (if save-history - comint-input-filter - 'ignore))) - (comint-send-input nil t)))) - -(defun guix-geiser-eval-in-repl (str &optional repl no-history no-display) - "Switch to Geiser REPL and evaluate STR with guile expression there. -If NO-HISTORY is non-nil, do not save STR in the REPL history. -If NO-DISPLAY is non-nil, do not switch to the REPL buffer." - (let ((repl (or repl (guix-geiser-repl)))) - (with-current-buffer repl - ;; XXX Since Geiser 0.8, `geiser-repl--send' has SAVE-HISTORY - ;; argument, so use this function eventually and remove - ;; `guix-repl-send'. - (guix-repl-send str (not no-history))) - (unless no-display - (geiser-repl--switch-to-buffer repl)))) - -(defun guix-geiser-eval-in-repl-synchronously (str &optional repl - no-history no-display) - "Evaluate STR in Geiser REPL synchronously, i.e. wait until the -REPL operation will be finished. -See `guix-geiser-eval-in-repl' for the meaning of arguments." - (let* ((repl (if repl (get-buffer repl) (guix-geiser-repl))) - (running? nil) - (filter (lambda (output) - (setq running? - (and (get-buffer-process repl) - (not (guix-guile-prompt? output)))))) - (comint-output-filter-functions - (cons filter comint-output-filter-functions))) - (guix-geiser-eval-in-repl str repl no-history no-display) - (while running? - (sleep-for 0.1)))) - -(defun guix-geiser-call (proc &rest args) - "Call (PROC ARGS ...) synchronously using the current Geiser REPL. -PROC and ARGS should be strings." - (guix-geiser-eval - (apply #'guix-guile-make-call-expression proc args))) - -(defun guix-geiser-call-in-repl (proc &rest args) - "Call (PROC ARGS ...) in the current Geiser REPL. -PROC and ARGS should be strings." - (guix-geiser-eval-in-repl - (apply #'guix-guile-make-call-expression proc args))) - -(provide 'guix-geiser) - -;;; guix-geiser.el ends here diff --git a/emacs/guix-guile.el b/emacs/guix-guile.el deleted file mode 100644 index 792f825ca5..0000000000 --- a/emacs/guix-guile.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; guix-guile.el --- Auxiliary tools for working with guile code -*- 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 functions for parsing guile code, making guile -;; expressions, etc. - -;;; Code: - -(require 'geiser-guile) - -(defvar guix-guile-definition-regexp - (rx bol "(define" - (zero-or-one "*") - (zero-or-one "-public") - (one-or-more space) - (zero-or-one "(") - (group (one-or-more (or word (syntax symbol))))) - "Regexp used to find the guile definition.") - -(defun guix-guile-current-definition () - "Return string with name of the current top-level guile definition." - (save-excursion - (beginning-of-defun) - (if (looking-at guix-guile-definition-regexp) - (match-string-no-properties 1) - (error "Couldn't find the current definition")))) - -(defun guix-guile-current-module () - "Return a string with the current guile module. -Return nil, if current buffer does not define a module." - ;; Modified version of `geiser-guile--get-module'. - (save-excursion - (geiser-syntax--pop-to-top) - (when (or (re-search-backward geiser-guile--module-re nil t) - (looking-at geiser-guile--library-re) - (re-search-forward geiser-guile--module-re nil t)) - (match-string-no-properties 1)))) - -(defun guix-guile-boolean (arg) - "Return a string with guile boolean value. -Transform elisp ARG (nil or non-nil) to the guile boolean (#f or #t)." - (if arg "#t" "#f")) - -(defun guix-guile-keyword-regexp (keyword) - "Return regexp to find guile KEYWORD." - (format "(\\(%s\\)\\_>" keyword)) - -(defun guix-guile-make-call-expression (proc &rest args) - "Return \"(PROC ARGS ...)\" string. -PROC and ARGS should be strings." - (format "(%s %s)" - proc - (mapconcat #'identity args " "))) - -(defun guix-make-guile-expression (fun &rest args) - "Return string containing a guile expression for calling FUN with ARGS." - (format "(%S %s)" fun - (mapconcat - (lambda (arg) - (cond - ((null arg) "'()") - ((or (eq arg t) - ;; An ugly hack to separate 'false' from nil. - (equal arg 'f) - (keywordp arg)) - (concat "#" (prin1-to-string arg t))) - ((or (symbolp arg) (listp arg)) - (concat "'" (prin1-to-string arg))) - (t (prin1-to-string arg)))) - args - " "))) - -(defun guix-guile-prompt? (string) - "Return non-nil, if STRING contains a Guile prompt." - (or (string-match-p geiser-guile--prompt-regexp string) - (string-match-p geiser-guile--debugger-prompt-regexp string))) - -(provide 'guix-guile) - -;;; guix-guile.el ends here diff --git a/emacs/guix-help-vars.el b/emacs/guix-help-vars.el deleted file mode 100644 index 8117d28f3e..0000000000 --- a/emacs/guix-help-vars.el +++ /dev/null @@ -1,108 +0,0 @@ -;;; guix-help-vars.el --- Variables related to --help output - -;; 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 regular expressions to parse various "guix -;; ... --help" outputs and lists of non-receivable items (system types, -;; hash formats, etc.). - -;;; Code: - - -;;; Regexps for parsing "guix ..." outputs - -(defvar guix-help-parse-option-regexp - (rx bol " " - (zero-or-one (group "-" (not (any "- "))) - ",") - (one-or-more " ") - (group "--" (one-or-more (or wordchar "-"))) - (group (zero-or-one "[") - (zero-or-one "=")) - (zero-or-more (not space)) - (one-or-more space) - (group (one-or-more any))) - "Common regexp used to find command options.") - -(defvar guix-help-parse-command-regexp - (rx bol " " - (group wordchar (one-or-more (or wordchar "-")))) - "Regexp used to find guix commands. -'Command' means any option not prefixed with '-'. For example, -guix subcommand, system action, importer, etc.") - -(defvar guix-help-parse-long-option-regexp - (rx (or " " ", ") - (group "--" (one-or-more (or wordchar "-")) - (zero-or-one "="))) - "Regexp used to find long options.") - -(defvar guix-help-parse-short-option-regexp - (rx bol (one-or-more blank) - "-" (group (not (any "- ")))) - "Regexp used to find short options.") - -(defvar guix-help-parse-package-regexp - (rx bol (group (one-or-more (not blank)))) - "Regexp used to find names of the packages.") - -(defvar guix-help-parse-list-regexp - (rx bol (zero-or-more blank) "- " - (group (one-or-more (or wordchar "-")))) - "Regexp used to find various lists (lint checkers, graph types).") - -(defvar guix-help-parse-regexp-group 1 - "Parenthesized expression of regexps used to find commands and -options.") - - -;;; Non-receivable lists of system types, hash formats, etc. - -(defvar guix-help-system-types - '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux") - "List of supported systems.") - -(defvar guix-help-source-types - '("package" "all" "transitive") - "List of supported sources types.") - -(defvar guix-help-hash-formats - '("nix-base32" "base32" "base16" "hex" "hexadecimal") - "List of supported hash formats.") - -(defvar guix-help-refresh-subsets - '("core" "non-core") - "List of supported 'refresh' subsets.") - -(defvar guix-help-key-policies - '("interactive" "always" "never") - "List of supported key download policies.") - -(defvar guix-help-verify-options - '("repair" "contents") - "List of supported 'verify' options") - -(defvar guix-help-elpa-archives - '("gnu" "melpa" "melpa-stable") - "List of supported ELPA archives.") - -(provide 'guix-help-vars) - -;;; guix-help-vars.el ends here diff --git a/emacs/guix-helper.scm.in b/emacs/guix-helper.scm.in deleted file mode 100644 index 0bbd36be21..0000000000 --- a/emacs/guix-helper.scm.in +++ /dev/null @@ -1,65 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This is an auxiliary file for the Emacs UI. It is used to add Guix -;; directories to path variables and to load the main code. - -;;; Code: - -(use-modules (ice-9 regex) - (srfi srfi-26)) - -(define %guix-dir) - -;; The code is taken from ‘guix’ executable script -(define (set-paths!) - (define-syntax-rule (push! elt v) (set! v (cons elt v))) - - (define config-lookup - (let ((config '(("prefix" . "@prefix@") - ("guilemoduledir" . "@guilemoduledir@"))) - (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}"))) - (define (expand-var-ref match) - (lookup (match:substring match 1))) - (define (expand str) - (regexp-substitute/global #f var-ref-regexp str - 'pre expand-var-ref 'post)) - (define (lookup name) - (expand (assoc-ref config name))) - lookup)) - - (let ((module-dir (config-lookup "guilemoduledir")) - (updates-dir (and=> (or (getenv "XDG_CONFIG_HOME") - (and=> (getenv "HOME") - (cut string-append <> "/.config"))) - (cut string-append <> "/guix/latest")))) - (push! module-dir %load-path) - (push! module-dir %load-compiled-path) - (if (and updates-dir (file-exists? updates-dir)) - (begin - (set! %guix-dir updates-dir) - (push! updates-dir %load-path) - (push! updates-dir %load-compiled-path)) - (set! %guix-dir module-dir)))) - -(set-paths!) - -(load-from-path "guix-main") - diff --git a/emacs/guix-history.el b/emacs/guix-history.el deleted file mode 100644 index 5d301a689e..0000000000 --- a/emacs/guix-history.el +++ /dev/null @@ -1,92 +0,0 @@ -;;; guix-history.el --- History of buffer information - -;; Copyright © 2014 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 support for history of buffers similar to the -;; history of a `help-mode' buffer. - -;;; Code: - -(require 'cl-macs) - -(defvar-local guix-history-stack-item nil - "Current item of the history. -A list of the form (FUNCTION [ARGS ...]). -The item is used by calling (apply FUNCTION ARGS).") -(put 'guix-history-stack-item 'permanent-local t) - -(defvar-local guix-history-back-stack nil - "Stack (list) of visited items. -Each element of the list has a form of `guix-history-stack-item'.") -(put 'guix-history-back-stack 'permanent-local t) - -(defvar-local guix-history-forward-stack nil - "Stack (list) of items visited with `guix-history-back'. -Each element of the list has a form of `guix-history-stack-item'.") -(put 'guix-history-forward-stack 'permanent-local t) - -(defvar guix-history-size 0 - "Maximum number of items saved in history. -If 0, the history is disabled.") - -(defun guix-history-add (item) - "Add ITEM to history." - (and guix-history-stack-item - (push guix-history-stack-item guix-history-back-stack)) - (setq guix-history-forward-stack nil - guix-history-stack-item item) - (when (>= (length guix-history-back-stack) - guix-history-size) - (setq guix-history-back-stack - (cl-loop for elt in guix-history-back-stack - for i from 1 to guix-history-size - collect elt)))) - -(defun guix-history-replace (item) - "Replace current item in history with ITEM." - (setq guix-history-stack-item item)) - -(defun guix-history-goto (item) - "Go to the ITEM of history. -ITEM should have the form of `guix-history-stack-item'." - (or (listp item) - (error "Wrong value of history element")) - (setq guix-history-stack-item item) - (apply (car item) (cdr item))) - -(defun guix-history-back () - "Go back to the previous element of history in the current buffer." - (interactive) - (or guix-history-back-stack - (user-error "No previous element in history")) - (push guix-history-stack-item guix-history-forward-stack) - (guix-history-goto (pop guix-history-back-stack))) - -(defun guix-history-forward () - "Go forward to the next element of history in the current buffer." - (interactive) - (or guix-history-forward-stack - (user-error "No next element in history")) - (push guix-history-stack-item guix-history-back-stack) - (guix-history-goto (pop guix-history-forward-stack))) - -(provide 'guix-history) - -;;; guix-history.el ends here diff --git a/emacs/guix-hydra-build.el b/emacs/guix-hydra-build.el deleted file mode 100644 index 232221e773..0000000000 --- a/emacs/guix-hydra-build.el +++ /dev/null @@ -1,362 +0,0 @@ -;;; guix-hydra-build.el --- Interface for Hydra builds -*- 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 an interface for displaying Hydra builds in -;; 'list' and 'info' buffers. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-hydra) -(require 'guix-build-log) -(require 'guix-utils) - -(guix-hydra-define-entry-type hydra-build - :search-types '((latest . guix-hydra-build-latest-api-url) - (queue . guix-hydra-build-queue-api-url)) - :filters '(guix-hydra-build-filter-status) - :filter-names '((nixname . name) - (buildstatus . build-status) - (timestamp . time)) - :filter-boolean-params '(finished busy)) - -(defun guix-hydra-build-get-display (search-type &rest args) - "Search for Hydra builds and show results." - (apply #'guix-list-get-display-entries - 'hydra-build search-type args)) - -(cl-defun guix-hydra-build-latest-prompt-args (&key project jobset - job system) - "Prompt for and return a list of 'latest builds' arguments." - (let* ((number (read-number "Number of latest builds: ")) - (project (if current-prefix-arg - (guix-hydra-read-project nil project) - project)) - (jobset (if current-prefix-arg - (guix-hydra-read-jobset nil jobset) - jobset)) - (job-or-name (if current-prefix-arg - (guix-hydra-read-job nil job) - job)) - (job (and job-or-name - (string-match-p guix-hydra-job-regexp - job-or-name) - job-or-name)) - (system (if (and (not job) - (or current-prefix-arg - (and job-or-name (not system)))) - (if job-or-name - (guix-while-null - (guix-hydra-read-system - (concat job-or-name ".") system)) - (guix-hydra-read-system nil system)) - system)) - (job (or job - (and job-or-name - (concat job-or-name "." system))))) - (list number - :project project - :jobset jobset - :job job - :system system))) - -(defun guix-hydra-build-view-log (id) - "View build log of a hydra build ID." - (guix-build-log-find-file (guix-hydra-build-log-url id))) - - -;;; Defining URLs - -(defun guix-hydra-build-url (id) - "Return Hydra URL of a build ID." - (guix-hydra-url "build/" (number-to-string id))) - -(defun guix-hydra-build-log-url (id) - "Return Hydra URL of the log file of a build ID." - (concat (guix-hydra-build-url id) "/log/raw")) - -(cl-defun guix-hydra-build-latest-api-url - (number &key project jobset job system) - "Return Hydra API URL to receive latest NUMBER of builds." - (guix-hydra-api-url "latestbuilds" - `(("nr" . ,number) - ("project" . ,project) - ("jobset" . ,jobset) - ("job" . ,job) - ("system" . ,system)))) - -(defun guix-hydra-build-queue-api-url (number) - "Return Hydra API URL to receive the NUMBER of queued builds." - (guix-hydra-api-url "queue" - `(("nr" . ,number)))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-build-filter-status (entry) - "Add 'status' parameter to 'hydra-build' ENTRY." - (let ((status (if (guix-entry-value entry 'finished) - (guix-hydra-build-status-number->name - (guix-entry-value entry 'build-status)) - (if (guix-entry-value entry 'busy) - 'running - 'scheduled)))) - (cons `(status . ,status) - entry))) - - -;;; Build status - -(defface guix-hydra-build-status-running - '((t :inherit bold)) - "Face used if hydra build is not finished." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-scheduled - '((t)) - "Face used if hydra build is scheduled." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-succeeded - '((t :inherit success)) - "Face used if hydra build succeeded." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-cancelled - '((t :inherit warning)) - "Face used if hydra build was cancelled." - :group 'guix-hydra-build-faces) - -(defface guix-hydra-build-status-failed - '((t :inherit error)) - "Face used if hydra build failed." - :group 'guix-hydra-build-faces) - -(defvar guix-hydra-build-status-alist - '((0 . succeeded) - (1 . failed-build) - (2 . failed-dependency) - (3 . failed-other) - (4 . cancelled)) - "Alist of hydra build status numbers and status names. -Status numbers are returned by Hydra API, names (symbols) are -used internally by the elisp code of this package.") - -(defun guix-hydra-build-status-number->name (number) - "Convert build status number to a name. -See `guix-hydra-build-status-alist'." - (guix-assq-value guix-hydra-build-status-alist number)) - -(defun guix-hydra-build-status-string (status) - "Return a human readable string for build STATUS." - (cl-case status - (scheduled - (guix-get-string "Scheduled" 'guix-hydra-build-status-scheduled)) - (running - (guix-get-string "Running" 'guix-hydra-build-status-running)) - (succeeded - (guix-get-string "Succeeded" 'guix-hydra-build-status-succeeded)) - (cancelled - (guix-get-string "Cancelled" 'guix-hydra-build-status-cancelled)) - (failed-build - (guix-hydra-build-status-fail-string)) - (failed-dependency - (guix-hydra-build-status-fail-string "dependency")) - (failed-other - (guix-hydra-build-status-fail-string "other")))) - -(defun guix-hydra-build-status-fail-string (&optional reason) - "Return a string for a failed build." - (let ((base (guix-get-string "Failed" 'guix-hydra-build-status-failed))) - (if reason - (concat base " (" reason ")") - base))) - -(defun guix-hydra-build-finished? (entry) - "Return non-nil, if hydra build was finished." - (guix-entry-value entry 'finished)) - -(defun guix-hydra-build-running? (entry) - "Return non-nil, if hydra build is running." - (eq (guix-entry-value entry 'status) - 'running)) - -(defun guix-hydra-build-scheduled? (entry) - "Return non-nil, if hydra build is scheduled." - (eq (guix-entry-value entry 'status) - 'scheduled)) - -(defun guix-hydra-build-succeeded? (entry) - "Return non-nil, if hydra build succeeded." - (eq (guix-entry-value entry 'status) - 'succeeded)) - -(defun guix-hydra-build-cancelled? (entry) - "Return non-nil, if hydra build was cancelled." - (eq (guix-entry-value entry 'status) - 'cancelled)) - -(defun guix-hydra-build-failed? (entry) - "Return non-nil, if hydra build failed." - (memq (guix-entry-value entry 'status) - '(failed-build failed-dependency failed-other))) - - -;;; Hydra build 'info' - -(guix-hydra-info-define-interface hydra-build - :mode-name "Hydra-Build-Info" - :buffer-name "*Guix Hydra Build Info*" - :format '((name ignore (simple guix-info-heading)) - ignore - guix-hydra-build-info-insert-url - (time format (time)) - (status format guix-hydra-build-info-insert-status) - (project format (format guix-hydra-build-project)) - (jobset format (format guix-hydra-build-jobset)) - (job format (format guix-hydra-build-job)) - (system format (format guix-hydra-build-system)) - (priority format (format)))) - -(defface guix-hydra-build-info-project - '((t :inherit link)) - "Face for project names." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-jobset - '((t :inherit link)) - "Face for jobsets." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-job - '((t :inherit link)) - "Face for jobs." - :group 'guix-hydra-build-info-faces) - -(defface guix-hydra-build-info-system - '((t :inherit link)) - "Face for system names." - :group 'guix-hydra-build-info-faces) - -(defmacro guix-hydra-build-define-button (name) - "Define `guix-hydra-build-NAME' button." - (let* ((name-str (symbol-name name)) - (button-name (intern (concat "guix-hydra-build-" name-str))) - (face-name (intern (concat "guix-hydra-build-info-" name-str))) - (keyword (intern (concat ":" name-str)))) - `(define-button-type ',button-name - :supertype 'guix - 'face ',face-name - 'help-echo ,(format "\ -Show latest builds for this %s (with prefix, prompt for all parameters)" - name-str) - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - ,keyword (button-label btn)))) - (apply #'guix-hydra-build-get-display - 'latest args)))))) - -(guix-hydra-build-define-button project) -(guix-hydra-build-define-button jobset) -(guix-hydra-build-define-button job) -(guix-hydra-build-define-button system) - -(defun guix-hydra-build-info-insert-url (entry) - "Insert Hydra URL for the build ENTRY." - (guix-insert-button (guix-hydra-build-url (guix-entry-id entry)) - 'guix-url) - (when (guix-hydra-build-finished? entry) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Build log" - (lambda (btn) - (guix-hydra-build-view-log (button-get btn 'id))) - "View build log" - 'id (guix-entry-id entry)))) - -(defun guix-hydra-build-info-insert-status (status &optional _) - "Insert a string with build STATUS." - (insert (guix-hydra-build-status-string status))) - - -;;; Hydra build 'list' - -(guix-hydra-list-define-interface hydra-build - :mode-name "Hydra-Build-List" - :buffer-name "*Guix Hydra Build List*" - :format '((name nil 30 t) - (system nil 16 t) - (status guix-hydra-build-list-get-status 20 t) - (project nil 10 t) - (jobset nil 17 t) - (time guix-list-get-time 20 t))) - -(let ((map guix-hydra-build-list-mode-map)) - (define-key map (kbd "B") 'guix-hydra-build-list-latest-builds) - (define-key map (kbd "L") 'guix-hydra-build-list-view-log)) - -(defun guix-hydra-build-list-get-status (status &optional _) - "Return a string for build STATUS." - (guix-hydra-build-status-string status)) - -(defun guix-hydra-build-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current job. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :project (guix-entry-value entry 'project) - :jobset (guix-entry-value entry 'name) - :job (guix-entry-value entry 'job) - :system (guix-entry-value entry 'system)))) - (apply #'guix-hydra-latest-builds number args)) - -(defun guix-hydra-build-list-view-log () - "View build log of the current Hydra build." - (interactive) - (guix-hydra-build-view-log (guix-list-current-id))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-hydra-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds. -ARGS are the same arguments as for `guix-hydra-build-latest-api-url'. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive (guix-hydra-build-latest-prompt-args)) - (apply #'guix-hydra-build-get-display - 'latest number args)) - -;;;###autoload -(defun guix-hydra-queued-builds (number) - "Display the NUMBER of queued Hydra builds." - (interactive "NNumber of queued builds: ") - (guix-hydra-build-get-display 'queue number)) - -(provide 'guix-hydra-build) - -;;; guix-hydra-build.el ends here diff --git a/emacs/guix-hydra-jobset.el b/emacs/guix-hydra-jobset.el deleted file mode 100644 index a4a55a36f2..0000000000 --- a/emacs/guix-hydra-jobset.el +++ /dev/null @@ -1,162 +0,0 @@ -;;; guix-hydra-jobset.el --- Interface for Hydra jobsets -*- 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 an interface for displaying Hydra jobsets in -;; 'list' and 'info' buffers. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-hydra) -(require 'guix-hydra-build) -(require 'guix-utils) - -(guix-hydra-define-entry-type hydra-jobset - :search-types '((project . guix-hydra-jobset-api-url)) - :filters '(guix-hydra-jobset-filter-id) - :filter-names '((nrscheduled . scheduled) - (nrsucceeded . succeeded) - (nrfailed . failed) - (nrtotal . total))) - -(defun guix-hydra-jobset-get-display (search-type &rest args) - "Search for Hydra builds and show results." - (apply #'guix-list-get-display-entries - 'hydra-jobset search-type args)) - - -;;; Defining URLs - -(defun guix-hydra-jobset-url (project jobset) - "Return Hydra URL of a PROJECT's JOBSET." - (guix-hydra-url "jobset/" project "/" jobset)) - -(defun guix-hydra-jobset-api-url (project) - "Return Hydra API URL for jobsets by PROJECT." - (guix-hydra-api-url "jobsets" - `(("project" . ,project)))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-jobset-filter-id (entry) - "Add 'ID' parameter to 'hydra-jobset' ENTRY." - (cons `(id . ,(guix-entry-value entry 'name)) - entry)) - - -;;; Hydra jobset 'info' - -(guix-hydra-info-define-interface hydra-jobset - :mode-name "Hydra-Jobset-Info" - :buffer-name "*Guix Hydra Jobset Info*" - :format '((name ignore (simple guix-info-heading)) - ignore - guix-hydra-jobset-info-insert-url - (project format guix-hydra-jobset-info-insert-project) - (scheduled format (format guix-hydra-jobset-info-scheduled)) - (succeeded format (format guix-hydra-jobset-info-succeeded)) - (failed format (format guix-hydra-jobset-info-failed)) - (total format (format guix-hydra-jobset-info-total)))) - -(defface guix-hydra-jobset-info-scheduled - '((t)) - "Face used for the number of scheduled builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-succeeded - '((t :inherit guix-hydra-build-status-succeeded)) - "Face used for the number of succeeded builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-failed - '((t :inherit guix-hydra-build-status-failed)) - "Face used for the number of failed builds." - :group 'guix-hydra-jobset-info-faces) - -(defface guix-hydra-jobset-info-total - '((t)) - "Face used for the total number of builds." - :group 'guix-hydra-jobset-info-faces) - -(defun guix-hydra-jobset-info-insert-project (project entry) - "Insert PROJECT button for the jobset ENTRY." - (let ((jobset (guix-entry-value entry 'name))) - (guix-insert-button - project 'guix-hydra-build-project - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - :project (button-get btn 'project) - :jobset (button-get btn 'jobset)))) - (apply #'guix-hydra-build-get-display - 'latest args))) - 'project project - 'jobset jobset))) - -(defun guix-hydra-jobset-info-insert-url (entry) - "Insert Hydra URL for the jobset ENTRY." - (guix-insert-button (guix-hydra-jobset-url - (guix-entry-value entry 'project) - (guix-entry-value entry 'name)) - 'guix-url)) - - -;;; Hydra jobset 'list' - -(guix-hydra-list-define-interface hydra-jobset - :mode-name "Hydra-Jobset-List" - :buffer-name "*Guix Hydra Jobset List*" - :format '((name nil 25 t) - (project nil 10 t) - (scheduled nil 12 t) - (succeeded nil 12 t) - (failed nil 9 t) - (total nil 10 t))) - -(let ((map guix-hydra-jobset-list-mode-map)) - (define-key map (kbd "B") 'guix-hydra-jobset-list-latest-builds)) - -(defun guix-hydra-jobset-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current jobset. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :project (guix-entry-value entry 'project) - :jobset (guix-entry-value entry 'name)))) - (apply #'guix-hydra-latest-builds number args)) - - -;;; Interactive commands - -;;;###autoload -(defun guix-hydra-jobsets (project) - "Display jobsets of PROJECT." - (interactive (list (guix-hydra-read-project))) - (guix-hydra-jobset-get-display 'project project)) - -(provide 'guix-hydra-jobset) - -;;; guix-hydra-jobset.el ends here diff --git a/emacs/guix-hydra.el b/emacs/guix-hydra.el deleted file mode 100644 index 9f876e7eea..0000000000 --- a/emacs/guix-hydra.el +++ /dev/null @@ -1,367 +0,0 @@ -;;; guix-hydra.el --- Common code for interacting with Hydra -*- 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 some general code for 'list'/'info' interfaces for -;; Hydra (Guix build farm). - -;;; Code: - -(require 'json) -(require 'guix-buffer) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-help-vars) - -(guix-define-groups hydra) - -(defvar guix-hydra-job-regexp - (concat ".*\\." (regexp-opt guix-help-system-types) "\\'") - "Regexp matching a full name of Hydra job (including system).") - -(defun guix-hydra-job-name-specification (name version) - "Return Hydra's job name specification by NAME and VERSION." - (concat name "-" version)) - -(defun guix-hydra-message (entries search-type &rest _) - "Display a message after showing Hydra ENTRIES." - ;; XXX Add more messages maybe. - (when (null entries) - (if (eq search-type 'fake) - (message "The update is impossible due to lack of Hydra API.") - (message "Hydra has returned no results.")))) - -(defun guix-hydra-list-describe (ids) - "Describe 'hydra' entries with IDS (list of identifiers)." - (guix-buffer-display-entries - (guix-entries-by-ids ids (guix-buffer-current-entries)) - 'info (guix-buffer-current-entry-type) - ;; Hydra does not provide an API to receive builds/jobsets by - ;; IDs/names, so we use a 'fake' search type. - '(fake) - 'add)) - - -;;; Readers - -(defvar guix-hydra-projects - '("gnu" "guix") - "List of available Hydra projects.") - -(guix-define-readers - :completions-var guix-hydra-projects - :single-reader guix-hydra-read-project - :single-prompt "Project: ") - -(guix-define-readers - :single-reader guix-hydra-read-jobset - :single-prompt "Jobset: ") - -(guix-define-readers - :single-reader guix-hydra-read-job - :single-prompt "Job: ") - -(guix-define-readers - :completions-var guix-help-system-types - :single-reader guix-hydra-read-system - :single-prompt "System: ") - - -;;; Defining URLs - -(defvar guix-hydra-url "http://hydra.gnu.org" - "URL of the Hydra build farm.") - -(defun guix-hydra-url (&rest url-parts) - "Return Hydra URL." - (apply #'concat guix-hydra-url "/" url-parts)) - -(defun guix-hydra-api-url (type args) - "Return URL for receiving data using Hydra API. -TYPE is the name of an allowed method. -ARGS is alist of (KEY . VALUE) pairs. -Skip ARG, if VALUE is nil or an empty string." - (declare (indent 1)) - (let* ((fields (mapcar - (lambda (arg) - (pcase arg - (`(,key . ,value) - (unless (or (null value) - (equal "" value)) - (concat (guix-hexify key) "=" - (guix-hexify value)))) - (_ (error "Wrong argument '%s'" arg)))) - args)) - (fields (mapconcat #'identity (delq nil fields) "&"))) - (guix-hydra-url "api/" type "?" fields))) - - -;;; Receiving data from Hydra - -(defun guix-hydra-receive-data (url) - "Return output received from URL and processed with `json-read'." - (with-temp-buffer - (url-insert-file-contents url) - (goto-char (point-min)) - (let ((json-key-type 'symbol) - (json-array-type 'list) - (json-object-type 'alist)) - (json-read)))) - -(defun guix-hydra-get-entries (entry-type search-type &rest args) - "Receive ENTRY-TYPE entries from Hydra. -SEARCH-TYPE is one of the types defined by `guix-hydra-define-interface'." - (unless (eq search-type 'fake) - (let* ((url (apply #'guix-hydra-search-url - entry-type search-type args)) - (raw-entries (guix-hydra-receive-data url)) - (entries (guix-hydra-filter-entries - raw-entries - (guix-hydra-filters entry-type)))) - entries))) - - -;;; Filters for processing raw entries - -(defun guix-hydra-filter-entries (entries filters) - "Filter ENTRIES using FILTERS. -Call `guix-modify' on each entry from ENTRIES." - (mapcar (lambda (entry) - (guix-modify entry filters)) - entries)) - -(defun guix-hydra-filter-names (entry name-alist) - "Replace names of ENTRY parameters using NAME-ALIST. -Each element of NAME-ALIST is (OLD-NAME . NEW-NAME) pair." - (mapcar (lambda (param) - (pcase param - (`(,name . ,val) - (let ((new-name (guix-assq-value name-alist name))) - (if new-name - (cons new-name val) - param))))) - entry)) - -(defun guix-hydra-filter-boolean (entry params) - "Convert number PARAMS (0/1) of ENTRY to boolean values (nil/t)." - (mapcar (lambda (param) - (pcase param - (`(,name . ,val) - (if (memq name params) - (cons name (guix-number->bool val)) - param)))) - entry)) - - -;;; Wrappers for defined variables - -(defvar guix-hydra-entry-type-data nil - "Alist with hydra entry type data. -This alist is filled by `guix-hydra-define-entry-type' macro.") - -(defun guix-hydra-entry-type-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-hydra'." - (symbol-value (guix-assq-value guix-hydra-entry-type-data - entry-type symbol))) - -(defun guix-hydra-search-url (entry-type search-type &rest args) - "Return URL to receive ENTRY-TYPE entries from Hydra." - (apply (guix-assq-value (guix-hydra-entry-type-value - entry-type 'search-types) - search-type) - args)) - -(defun guix-hydra-filters (entry-type) - "Return a list of filters for ENTRY-TYPE." - (guix-hydra-entry-type-value entry-type 'filters)) - - -;;; Interface definers - -(defmacro guix-hydra-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:search-types' - default value of the generated - `guix-ENTRY-TYPE-search-types' variable. - -Optional keywords: - - - `:filters' - default value of the generated - `guix-ENTRY-TYPE-filters' variable. - - - `:filter-names' - if specified, a generated - `guix-ENTRY-TYPE-filter-names' function for filtering these - names will be added to `guix-ENTRY-TYPE-filters' variable. - - - `:filter-boolean-params' - if specified, a generated - `guix-ENTRY-TYPE-filter-boolean' function for filtering these - names will be added to `guix-ENTRY-TYPE-filters' variable. - -The rest keyword arguments are passed to -`guix-define-entry-type' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str)) - (search-types-var (intern (concat prefix "-search-types"))) - (filters-var (intern (concat prefix "-filters"))) - (get-fun (intern (concat prefix "-get-entries")))) - (guix-keyword-args-let args - ((search-types-val :search-types) - (filters-val :filters) - (filter-names-val :filter-names) - (filter-bool-val :filter-boolean-params)) - `(progn - (defvar ,search-types-var ,search-types-val - ,(format "\ -Alist of search types and according URL functions. -Functions are used to define URL to receive '%s' entries." - entry-type-str)) - - (defvar ,filters-var ,filters-val - ,(format "\ -List of filters for '%s' parameters. -Each filter is a function that should take an entry as a single -argument, and should also return an entry." - entry-type-str)) - - ,(when filter-bool-val - (let ((filter-bool-var (intern (concat prefix - "-filter-boolean-params"))) - (filter-bool-fun (intern (concat prefix - "-filter-boolean")))) - `(progn - (defvar ,filter-bool-var ,filter-bool-val - ,(format "\ -List of '%s' parameters that should be transformed to boolean values." - entry-type-str)) - - (defun ,filter-bool-fun (entry) - ,(format "\ -Run `guix-hydra-filter-boolean' with `%S' variable." - filter-bool-var) - (guix-hydra-filter-boolean entry ,filter-bool-var)) - - (setq ,filters-var - (cons ',filter-bool-fun ,filters-var))))) - - ;; Do not move this clause up!: name filtering should be - ;; performed before any other filtering, so this filter should - ;; be consed after the boolean filter. - ,(when filter-names-val - (let* ((filter-names-var (intern (concat prefix - "-filter-names"))) - (filter-names-fun filter-names-var)) - `(progn - (defvar ,filter-names-var ,filter-names-val - ,(format "\ -Alist of '%s' parameter names returned by Hydra API and names -used internally by the elisp code of this package." - entry-type-str)) - - (defun ,filter-names-fun (entry) - ,(format "\ -Run `guix-hydra-filter-names' with `%S' variable." - filter-names-var) - (guix-hydra-filter-names entry ,filter-names-var)) - - (setq ,filters-var - (cons ',filter-names-fun ,filters-var))))) - - (defun ,get-fun (search-type &rest args) - ,(format "\ -Receive '%s' entries. -See `guix-hydra-get-entries' for details." - entry-type-str) - (apply #'guix-hydra-get-entries - ',entry-type search-type args)) - - (guix-alist-put! - '((search-types . ,search-types-var) - (filters . ,filters-var)) - 'guix-hydra-entry-type-data ',entry-type) - - (guix-define-entry-type ,entry-type - :parent-group guix-hydra - :parent-faces-group guix-hydra-faces - ,@%foreign-args))))) - -(defmacro guix-hydra-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. - -This macro should be called after calling -`guix-hydra-define-entry-type' with the same ENTRY-TYPE. - -ARGS are passed to `guix-BUFFER-TYPE-define-interface' macro." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (get-fun (intern (concat "guix-" entry-type-str - "-get-entries"))) - (definer (intern (concat "guix-" buffer-type-str - "-define-interface")))) - `(,definer ,entry-type - :get-entries-function ',get-fun - :message-function 'guix-hydra-message - ,@args))) - -(defmacro guix-hydra-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -See `guix-hydra-define-interface'." - (declare (indent 1)) - `(guix-hydra-define-interface info ,entry-type - ,@args)) - -(defmacro guix-hydra-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-list-describe-function' variable (if not - specified, use `guix-hydra-list-describe'). - -The rest keyword arguments are passed to -`guix-hydra-define-interface' macro." - (declare (indent 1)) - (guix-keyword-args-let args - ((describe-val :describe-function)) - `(guix-hydra-define-interface list ,entry-type - :describe-function ,(or describe-val ''guix-hydra-list-describe) - ,@args))) - - -(defvar guix-hydra-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-hydra-define-entry-type" - "guix-hydra-define-interface" - "guix-hydra-info-define-interface" - "guix-hydra-list-define-interface")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-hydra-font-lock-keywords) - -(provide 'guix-hydra) - -;;; guix-hydra.el ends here diff --git a/emacs/guix-info.el b/emacs/guix-info.el deleted file mode 100644 index 6aefd2f3f6..0000000000 --- a/emacs/guix-info.el +++ /dev/null @@ -1,482 +0,0 @@ -;;; guix-info.el --- 'Info' buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> -;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> - -;; 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 'info' (help-like) buffer interface for displaying -;; an arbitrary data. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-entry) -(require 'guix-utils) - -(guix-define-buffer-type info) - -(defface guix-info-heading - '((((type tty pc) (class color)) :weight bold) - (t :height 1.6 :weight bold :inherit variable-pitch)) - "Face for headings." - :group 'guix-info-faces) - -(defface guix-info-param-title - '((t :inherit font-lock-type-face)) - "Face used for titles of parameters." - :group 'guix-info-faces) - -(defface guix-info-file-name - '((t :inherit link)) - "Face used for file names." - :group 'guix-info-faces) - -(defface guix-info-url - '((t :inherit link)) - "Face used for URLs." - :group 'guix-info-faces) - -(defface guix-info-time - '((t :inherit font-lock-constant-face)) - "Face used for timestamps." - :group 'guix-info-faces) - -(defface guix-info-action-button - '((((type x w32 ns) (class color)) - :box (:line-width 2 :style released-button) - :background "lightgrey" :foreground "black") - (t :inherit button)) - "Face used for action buttons." - :group 'guix-info-faces) - -(defface guix-info-action-button-mouse - '((((type x w32 ns) (class color)) - :box (:line-width 2 :style released-button) - :background "grey90" :foreground "black") - (t :inherit highlight)) - "Mouse face used for action buttons." - :group 'guix-info-faces) - -(defcustom guix-info-ignore-empty-values nil - "If non-nil, do not display parameters with nil values." - :type 'boolean - :group 'guix-info) - -(defcustom guix-info-fill t - "If non-nil, fill string parameters to fit the window. -If nil, insert text parameters (like synopsis or description) in -a raw form." - :type 'boolean - :group 'guix-info) - -(defvar guix-info-param-title-format "%-18s: " - "String used to format a title of a parameter. -It should be a '%s'-sequence. After inserting a title formatted -with this string, a value of the parameter is inserted. -This string is used by `guix-info-insert-title-format'.") - -(defvar guix-info-multiline-prefix - (make-string (length (format guix-info-param-title-format " ")) - ?\s) - "String used to format multi-line parameter values. -If a value occupies more than one line, this string is inserted -in the beginning of each line after the first one. -This string is used by `guix-info-insert-value-format'.") - -(defvar guix-info-indent 2 - "Number of spaces used to indent various parts of inserted text.") - -(defvar guix-info-delimiter "\n\f\n" - "String used to separate entries.") - - -;;; Wrappers for 'info' variables - -(defvar guix-info-data nil - "Alist with 'info' data. -This alist is filled by `guix-info-define-interface' macro.") - -(defun guix-info-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-info-data'." - (symbol-value (guix-assq-value guix-info-data entry-type symbol))) - -(defun guix-info-param-title (entry-type param) - "Return a title of an ENTRY-TYPE parameter PARAM." - (guix-buffer-param-title 'info entry-type param)) - -(defun guix-info-format (entry-type) - "Return 'info' format for ENTRY-TYPE." - (guix-info-value entry-type 'format)) - -(defun guix-info-displayed-params (entry-type) - "Return a list of ENTRY-TYPE parameters that should be displayed." - (delq nil - (mapcar (lambda (spec) - (pcase spec - (`(,param . ,_) param))) - (guix-info-format entry-type)))) - - -;;; Inserting entries - -(defvar guix-info-title-aliases - '((format . guix-info-insert-title-format) - (simple . guix-info-insert-title-simple)) - "Alist of aliases and functions to insert titles.") - -(defvar guix-info-value-aliases - '((format . guix-info-insert-value-format) - (indent . guix-info-insert-value-indent) - (simple . guix-info-insert-value-simple) - (time . guix-info-insert-time)) - "Alist of aliases and functions to insert values.") - -(defun guix-info-title-function (fun-or-alias) - "Convert FUN-OR-ALIAS into a function to insert a title." - (or (guix-assq-value guix-info-title-aliases fun-or-alias) - fun-or-alias)) - -(defun guix-info-value-function (fun-or-alias) - "Convert FUN-OR-ALIAS into a function to insert a value." - (or (guix-assq-value guix-info-value-aliases fun-or-alias) - fun-or-alias)) - -(defun guix-info-title-method->function (method) - "Convert title METHOD into a function to insert a title." - (pcase method - ((pred null) #'ignore) - ((pred symbolp) (guix-info-title-function method)) - (`(,fun-or-alias . ,rest-args) - (lambda (title) - (apply (guix-info-title-function fun-or-alias) - title rest-args))) - (_ (error "Unknown title method '%S'" method)))) - -(defun guix-info-value-method->function (method) - "Convert value METHOD into a function to insert a value." - (pcase method - ((pred null) #'ignore) - ((pred functionp) method) - (`(,fun-or-alias . ,rest-args) - (lambda (value _) - (apply (guix-info-value-function fun-or-alias) - value rest-args))) - (_ (error "Unknown value method '%S'" method)))) - -(defun guix-info-fill-column () - "Return fill column for the current window." - (min (window-width) fill-column)) - -(defun guix-info-get-indent (&optional level) - "Return `guix-info-indent' \"multiplied\" by LEVEL spaces. -LEVEL is 1 by default." - (make-string (* guix-info-indent (or level 1)) ?\s)) - -(defun guix-info-insert-indent (&optional level) - "Insert `guix-info-indent' spaces LEVEL times (1 by default)." - (insert (guix-info-get-indent level))) - -(defun guix-info-insert-entries (entries entry-type) - "Display ENTRY-TYPE ENTRIES in the current info buffer." - (guix-mapinsert (lambda (entry) - (guix-info-insert-entry entry entry-type)) - entries - guix-info-delimiter)) - -(defun guix-info-insert-entry (entry entry-type &optional indent-level) - "Insert ENTRY of ENTRY-TYPE into the current info buffer. -If INDENT-LEVEL is non-nil, indent displayed data by this number -of `guix-info-indent' spaces." - (guix-with-indent (* (or indent-level 0) - guix-info-indent) - (dolist (spec (guix-info-format entry-type)) - (guix-info-insert-entry-unit spec entry entry-type)))) - -(defun guix-info-insert-entry-unit (format-spec entry entry-type) - "Insert title and value of a PARAM at point. -ENTRY is alist with parameters and their values. -ENTRY-TYPE is a type of ENTRY." - (pcase format-spec - ((pred functionp) - (funcall format-spec entry) - (insert "\n")) - (`(,param ,title-method ,value-method) - (let ((value (guix-entry-value entry param))) - (unless (and guix-info-ignore-empty-values (null value)) - (let ((title (guix-info-param-title entry-type param)) - (insert-title (guix-info-title-method->function title-method)) - (insert-value (guix-info-value-method->function value-method))) - (funcall insert-title title) - (funcall insert-value value entry) - (insert "\n"))))) - (_ (error "Unknown format specification '%S'" format-spec)))) - -(defun guix-info-insert-title-simple (title &optional face) - "Insert \"TITLE: \" string at point. -If FACE is nil, use `guix-info-param-title'." - (guix-format-insert title - (or face 'guix-info-param-title) - "%s: ")) - -(defun guix-info-insert-title-format (title &optional face) - "Insert TITLE using `guix-info-param-title-format' at point. -If FACE is nil, use `guix-info-param-title'." - (guix-format-insert title - (or face 'guix-info-param-title) - guix-info-param-title-format)) - -(defun guix-info-insert-value-simple (value &optional button-or-face indent) - "Format and insert parameter VALUE at point. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill', and each line is indented -with INDENT number of spaces. - -If BUTTON-OR-FACE is a button type symbol, transform VALUE into -this (these) button(s) and insert each one on a new line. If it -is a face symbol, propertize inserted line(s) with this face." - (or indent (setq indent 0)) - (guix-with-indent indent - (let* ((button? (guix-button-type? button-or-face)) - (face (unless button? button-or-face)) - (fill-col (unless (or button? - (and (stringp value) - (not guix-info-fill))) - (- (guix-info-fill-column) indent))) - (value (if (and value button?) - (guix-buttonize value button-or-face "\n") - value))) - (guix-split-insert value face fill-col "\n")))) - -(defun guix-info-insert-value-indent (value &optional button-or-face) - "Format and insert parameter VALUE at point. - -This function is intended to be called after inserting a title -with `guix-info-insert-title-simple'. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill', and each line is indented -with `guix-info-indent'. - -For the meaning of BUTTON-OR-FACE, see `guix-info-insert-value-simple'." - (when value (insert "\n")) - (guix-info-insert-value-simple value button-or-face guix-info-indent)) - -(defun guix-info-insert-value-format (value &optional button-or-face - &rest button-properties) - "Format and insert parameter VALUE at point. - -This function is intended to be called after inserting a title -with `guix-info-insert-title-format'. - -VALUE may be split into several short lines to fit the current -window, depending on `guix-info-fill' and -`guix-info-multiline-prefix'. If VALUE is a list, its elements -will be separated with `guix-list-separator'. - -If BUTTON-OR-FACE is a button type symbol, transform VALUE into -this (these) button(s). If it is a face symbol, propertize -inserted line(s) with this face. - -BUTTON-PROPERTIES are passed to `guix-buttonize' (only if -BUTTON-OR-FACE is a button type)." - (let* ((button? (guix-button-type? button-or-face)) - (face (unless button? button-or-face)) - (fill-col (when (or button? - guix-info-fill - (not (stringp value))) - (- (guix-info-fill-column) - (length guix-info-multiline-prefix)))) - (value (if (and value button?) - (apply #'guix-buttonize - value button-or-face guix-list-separator - button-properties) - value))) - (guix-split-insert value face fill-col - (concat "\n" guix-info-multiline-prefix)))) - -(defun guix-info-insert-time (seconds &optional face) - "Insert formatted time string using SECONDS at point." - (guix-format-insert (guix-get-time-string seconds) - (or face 'guix-info-time))) - - -;;; Buttons - -(defvar guix-info-button-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map button-map) - (define-key map (kbd "c") 'guix-info-button-copy-label) - map) - "Keymap for buttons in info buffers.") - -(define-button-type 'guix - 'keymap guix-info-button-map - 'follow-link t) - -(define-button-type 'guix-action - :supertype 'guix - 'face 'guix-info-action-button - 'mouse-face 'guix-info-action-button-mouse) - -(define-button-type 'guix-file - :supertype 'guix - 'face 'guix-info-file-name - 'help-echo "Find file" - 'action (lambda (btn) - (guix-find-file (button-label btn)))) - -(define-button-type 'guix-url - :supertype 'guix - 'face 'guix-info-url - 'help-echo "Browse URL" - 'action (lambda (btn) - (browse-url (button-label btn)))) - -(defun guix-info-button-copy-label (&optional pos) - "Copy a label of the button at POS into kill ring. -If POS is nil, use the current point position." - (interactive) - (let ((button (button-at (or pos (point))))) - (when button - (guix-copy-as-kill (button-label button))))) - -(defun guix-info-insert-action-button (label action &optional message - &rest properties) - "Make action button with LABEL and insert it at point. -ACTION is a function called when the button is pressed. It -should accept button as the argument. -MESSAGE is a button message. -See `insert-text-button' for the meaning of PROPERTIES." - (apply #'guix-insert-button - label 'guix-action - 'action action - 'help-echo message - properties)) - - -;;; Major mode and interface definer - -(defvar guix-info-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap (list guix-buffer-map button-buffer-map) - special-mode-map)) - map) - "Keymap for `guix-info-mode' buffers.") - -(define-derived-mode guix-info-mode special-mode "Guix-Info" - "Parent mode for displaying data in 'info' form." - (setq-local revert-buffer-function 'guix-buffer-revert)) - -(defun guix-info-mode-initialize () - "Set up the current 'info' buffer." - ;; Without this, syntactic fontification is performed, and it may - ;; break our highlighting. For example, description of "emacs-typo" - ;; package contains a single " (double-quote) character, so the - ;; default syntactic fontification highlights the rest text after it - ;; as a string. See (info "(elisp) Font Lock Basics") for details. - (setq font-lock-defaults '(nil t))) - -(defmacro guix-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:format' - default value of the generated - `guix-ENTRY-TYPE-info-format' variable. - -The rest keyword arguments are passed to -`guix-buffer-define-interface' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str "-info")) - (group (intern prefix)) - (format-var (intern (concat prefix "-format")))) - (guix-keyword-args-let args - ((show-entries-val :show-entries-function) - (format-val :format)) - `(progn - (defcustom ,format-var ,format-val - ,(format "\ -List of methods for inserting '%s' entry. -Each METHOD should be either a function or should have the -following form: - - (PARAM INSERT-TITLE INSERT-VALUE) - -If METHOD is a function, it is called with an entry as argument. - -PARAM is a name of '%s' entry parameter. - -INSERT-TITLE may be either a symbol or a list. If it is a -symbol, it should be a function or an alias from -`guix-info-title-aliases', in which case it is called with title -as argument. If it is a list, it should have a -form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is -called with title and ARGS as arguments. - -INSERT-VALUE may be either a symbol or a list. If it is a -symbol, it should be a function or an alias from -`guix-info-value-aliases', in which case it is called with value -and entry as arguments. If it is a list, it should have a -form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is -called with value and ARGS as arguments. - -Parameters are inserted in the same order as defined by this list. -After calling each METHOD, a new line is inserted." - entry-type-str entry-type-str) - :type 'sexp - :group ',group) - - (guix-alist-put! - '((format . ,format-var)) - 'guix-info-data ',entry-type) - - ,(if show-entries-val - `(guix-buffer-define-interface info ,entry-type - :show-entries-function ,show-entries-val - ,@%foreign-args) - - (let ((insert-fun (intern (concat prefix "-insert-entries")))) - `(progn - (defun ,insert-fun (entries) - ,(format "\ -Print '%s' ENTRIES in the current 'info' buffer." - entry-type-str) - (guix-info-insert-entries entries ',entry-type)) - - (guix-buffer-define-interface info ,entry-type - :insert-entries-function ',insert-fun - :mode-init-function 'guix-info-mode-initialize - ,@%foreign-args)))))))) - - -(defvar guix-info-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-info-define-interface") - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-info-font-lock-keywords) - -(provide 'guix-info) - -;;; guix-info.el ends here diff --git a/emacs/guix-init.el b/emacs/guix-init.el deleted file mode 100644 index bd75e54e03..0000000000 --- a/emacs/guix-init.el +++ /dev/null @@ -1,3 +0,0 @@ -(require 'guix-autoloads) -(message "(require 'guix-init) is obsolete, use (require 'guix-autoloads) instead.") -(provide 'guix-init) diff --git a/emacs/guix-license.el b/emacs/guix-license.el deleted file mode 100644 index 6003a21aac..0000000000 --- a/emacs/guix-license.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; guix-license.el --- Licenses - -;; Copyright © 2016 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 the code to work with licenses of Guix packages. - -;;; Code: - -(require 'guix-read) -(require 'guix-backend) -(require 'guix-guile) - -(defun guix-license-file (&optional directory) - "Return name of the file with license definitions. -DIRECTORY is a directory with Guix source (`guix-directory' by default)." - (expand-file-name "guix/licenses.scm" - (or directory guix-directory))) - -(defun guix-lookup-license-url (license) - "Return URL of a LICENSE." - (or (guix-eval-read (guix-make-guile-expression - 'lookup-license-uri license)) - (error "Hm, I don't know URL of '%s' license" license))) - -;;;###autoload -(defun guix-find-license-definition (license &optional directory) - "Open licenses file from DIRECTORY and move to the LICENSE definition. -See `guix-license-file' for the meaning of DIRECTORY. -Interactively, with prefix argument, prompt for DIRECTORY." - (interactive - (list (guix-read-license-name) - (guix-read-directory))) - (find-file (guix-license-file directory)) - (goto-char (point-min)) - (when (re-search-forward (concat "\"" (regexp-quote license) "\"") - nil t) - (beginning-of-defun) - (recenter 1))) - -;;;###autoload -(defun guix-browse-license-url (license) - "Browse URL of a LICENSE." - (interactive (list (guix-read-license-name))) - (browse-url (guix-lookup-license-url license))) - -(provide 'guix-license) - -;;; guix-license.el ends here diff --git a/emacs/guix-list.el b/emacs/guix-list.el deleted file mode 100644 index c91c67cb29..0000000000 --- a/emacs/guix-list.el +++ /dev/null @@ -1,585 +0,0 @@ -;;; guix-list.el --- 'List' buffer interface for displaying data -*- lexical-binding: t -*- - -;; Copyright © 2014, 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 'list' buffer interface for displaying an arbitrary -;; data. - -;;; Code: - -(require 'cl-lib) -(require 'tabulated-list) -(require 'guix-buffer) -(require 'guix-info) -(require 'guix-entry) -(require 'guix-utils) - -(guix-define-buffer-type list) - -(defface guix-list-file-name - '((t :inherit guix-info-file-name)) - "Face used for file names." - :group 'guix-list-faces) - -(defface guix-list-url - '((t :inherit guix-info-url)) - "Face used for URLs." - :group 'guix-list-faces) - -(defface guix-list-time - '((t :inherit guix-info-time)) - "Face used for time stamps." - :group 'guix-list-faces) - -(defun guix-list-describe (&optional mark-names) - "Describe entries marked with a general mark. -'Describe' means display entries in 'info' buffer. -If no entries are marked, describe the current entry. -With prefix argument, describe entries marked with any mark." - (interactive (list (unless current-prefix-arg '(general)))) - (let* ((ids (or (apply #'guix-list-get-marked-id-list mark-names) - (list (guix-list-current-id)))) - (count (length ids)) - (entry-type (guix-buffer-current-entry-type))) - (when (or (<= count (guix-list-describe-warning-count entry-type)) - (y-or-n-p (format "Do you really want to describe %d entries? " - count))) - (guix-list-describe-entries entry-type ids)))) - - -;;; Wrappers for 'list' variables - -(defvar guix-list-data nil - "Alist with 'list' data. -This alist is filled by `guix-list-define-interface' macro.") - -(defun guix-list-value (entry-type symbol) - "Return SYMBOL's value for ENTRY-TYPE from `guix-list-data'." - (symbol-value (guix-assq-value guix-list-data entry-type symbol))) - -(defun guix-list-param-title (entry-type param) - "Return column title of an ENTRY-TYPE parameter PARAM." - (guix-buffer-param-title 'list entry-type param)) - -(defun guix-list-format (entry-type) - "Return column format for ENTRY-TYPE." - (guix-list-value entry-type 'format)) - -(defun guix-list-displayed-params (entry-type) - "Return a list of ENTRY-TYPE parameters that should be displayed." - (mapcar #'car (guix-list-format entry-type))) - -(defun guix-list-sort-key (entry-type) - "Return sort key for ENTRY-TYPE." - (guix-list-value entry-type 'sort-key)) - -(defun guix-list-additional-marks (entry-type) - "Return alist of additional marks for ENTRY-TYPE." - (guix-list-value entry-type 'marks)) - -(defun guix-list-single-entry? (entry-type) - "Return non-nil, if a single entry of ENTRY-TYPE should be listed." - (guix-list-value entry-type 'list-single)) - -(defun guix-list-describe-warning-count (entry-type) - "Return the maximum number of ENTRY-TYPE entries to describe." - (guix-list-value entry-type 'describe-count)) - -(defun guix-list-describe-entries (entry-type ids) - "Describe ENTRY-TYPE entries with IDS in 'info' buffer" - (funcall (guix-list-value entry-type 'describe) - ids)) - - -;;; Tabulated list internals - -(defun guix-list-sort-numerically (column a b) - "Compare COLUMN of tabulated entries A and B numerically. -This function is used for sort predicates for `tabulated-list-format'. -Return non-nil, if B is bigger than A." - (cl-flet ((num (entry) - (string-to-number (aref (cadr entry) column)))) - (> (num b) (num a)))) - -(defmacro guix-list-define-numerical-sorter (column) - "Define numerical sort predicate for COLUMN. -See `guix-list-sort-numerically' for details." - (let ((name (intern (format "guix-list-sort-numerically-%d" column))) - (doc (format "\ -Predicate to sort tabulated list by column %d numerically. -See `guix-list-sort-numerically' for details." - column))) - `(defun ,name (a b) - ,doc - (guix-list-sort-numerically ,column a b)))) - -(defmacro guix-list-define-numerical-sorters (n) - "Define numerical sort predicates for columns from 0 to N. -See `guix-list-define-numerical-sorter' for details." - `(progn - ,@(mapcar (lambda (i) - `(guix-list-define-numerical-sorter ,i)) - (number-sequence 0 n)))) - -(guix-list-define-numerical-sorters 9) - -(defun guix-list-tabulated-sort-key (entry-type) - "Return ENTRY-TYPE sort key for `tabulated-list-sort-key'." - (let ((sort-key (guix-list-sort-key entry-type))) - (and sort-key - (cons (guix-list-param-title entry-type (car sort-key)) - (cdr sort-key))))) - -(defun guix-list-tabulated-vector (entry-type fun) - "Call FUN on each column specification for ENTRY-TYPE. - -FUN is applied to column specification as arguments (see -`guix-list-format'). - -Return a vector made of values of FUN calls." - (apply #'vector - (mapcar (lambda (col-spec) - (apply fun col-spec)) - (guix-list-format entry-type)))) - -(defun guix-list-tabulated-format (entry-type) - "Return ENTRY-TYPE list specification for `tabulated-list-format'." - (guix-list-tabulated-vector - entry-type - (lambda (param _ &rest rest-spec) - (cons (guix-list-param-title entry-type param) - rest-spec)))) - -(defun guix-list-tabulated-entries (entries entry-type) - "Return a list of ENTRY-TYPE values for `tabulated-list-entries'." - (mapcar (lambda (entry) - (list (guix-entry-id entry) - (guix-list-tabulated-entry entry entry-type))) - entries)) - -(defun guix-list-tabulated-entry (entry entry-type) - "Return array of values for `tabulated-list-entries'. -Parameters are taken from ENTRY-TYPE ENTRY." - (guix-list-tabulated-vector - entry-type - (lambda (param fun &rest _) - (let ((val (guix-entry-value entry param))) - (if fun - (funcall fun val entry) - (guix-get-string val)))))) - - -;;; Displaying entries - -(defun guix-list-get-display-entries (entry-type &rest args) - "Search for entries and show them in a 'list' buffer preferably." - (let ((entries (guix-buffer-get-entries 'list entry-type args))) - (if (or (null entries) ; = 0 - (cdr entries) ; > 1 - (guix-list-single-entry? entry-type) - (null (guix-buffer-value 'info entry-type 'show-entries))) - (guix-buffer-display-entries entries 'list entry-type args 'add) - (if (equal (guix-buffer-value 'info entry-type 'get-entries) - (guix-buffer-value 'list entry-type 'get-entries)) - (guix-buffer-display-entries entries 'info entry-type args 'add) - (guix-buffer-get-display-entries 'info entry-type args 'add))))) - -(defun guix-list-insert-entries (entries entry-type) - "Print ENTRY-TYPE ENTRIES in the current buffer." - (setq tabulated-list-entries - (guix-list-tabulated-entries entries entry-type)) - (tabulated-list-print)) - -(defun guix-list-get-one-line (val &optional _) - "Return one-line string from a multi-line string VAL. -VAL may be nil." - (if val - (guix-get-one-line val) - (guix-get-string nil))) - -(defun guix-list-get-time (seconds &optional _) - "Return formatted time string from SECONDS." - (guix-get-string (guix-get-time-string seconds) - 'guix-list-time)) - -(defun guix-list-get-file-name (file-name &optional _) - "Return FILE-NAME button specification for `tabulated-list-entries'." - (list file-name - 'face 'guix-list-file-name - 'action (lambda (btn) (find-file (button-label btn))) - 'follow-link t - 'help-echo "Find file")) - -(defun guix-list-get-url (url &optional _) - "Return URL button specification for `tabulated-list-entries'." - (list url - 'face 'guix-list-url - 'action (lambda (btn) (browse-url (button-label btn))) - 'follow-link t - 'help-echo "Browse URL")) - - -;;; 'List' lines - -(defun guix-list-current-id () - "Return ID of the entry at point." - (or (tabulated-list-get-id) - (user-error "No entry here"))) - -(defun guix-list-current-entry () - "Return entry at point." - (guix-entry-by-id (guix-list-current-id) - (guix-buffer-current-entries))) - -(defun guix-list-for-each-line (fun &rest args) - "Call FUN with ARGS for each entry line." - (or (derived-mode-p 'guix-list-mode) - (error "The current buffer is not in Guix List mode")) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (apply fun args) - (forward-line)))) - -(defun guix-list-fold-lines (fun init) - "Fold over entry lines in the current list buffer. -Call FUN with RESULT as argument for each line, using INIT as -the initial value of RESULT. Return the final result." - (let ((res init)) - (guix-list-for-each-line - (lambda () (setq res (funcall fun res)))) - res)) - - -;;; Marking and sorting - -(defvar-local guix-list-marked nil - "List of the marked entries. -Each element of the list has a form: - - (ID MARK-NAME . ARGS) - -ID is an entry ID. -MARK-NAME is a symbol from `guix-list-marks'. -ARGS is a list of additional values.") - -(defvar-local guix-list-marks nil - "Alist of available mark names and mark characters.") - -(defvar guix-list-default-marks - '((empty . ?\s) - (general . ?*)) - "Alist of default mark names and mark characters.") - -(defun guix-list-marks (entry-type) - "Return alist of available marks for ENTRY-TYPE." - (append guix-list-default-marks - (guix-list-additional-marks entry-type))) - -(defun guix-list-get-mark (name) - "Return mark character by its NAME." - (or (guix-assq-value guix-list-marks name) - (error "Mark '%S' not found" name))) - -(defun guix-list-get-mark-string (name) - "Return mark string by its NAME." - (string (guix-list-get-mark name))) - -(defun guix-list-current-mark () - "Return mark character of the current line." - (char-after (line-beginning-position))) - -(defun guix-list-get-marked (&rest mark-names) - "Return list of specs of entries marked with any mark from MARK-NAMES. -Entry specs are elements from `guix-list-marked' list. -If MARK-NAMES are not specified, use all marks from -`guix-list-marks' except the `empty' one." - (or mark-names - (setq mark-names - (delq 'empty - (mapcar #'car guix-list-marks)))) - (cl-remove-if-not (lambda (assoc) - (memq (cadr assoc) mark-names)) - guix-list-marked)) - -(defun guix-list-get-marked-args (mark-name) - "Return list of (ID . ARGS) elements from lines marked with MARK-NAME. -See `guix-list-marked' for the meaning of ARGS." - (mapcar (lambda (spec) - (let ((id (car spec)) - (args (cddr spec))) - (cons id args))) - (guix-list-get-marked mark-name))) - -(defun guix-list-get-marked-id-list (&rest mark-names) - "Return list of IDs of entries marked with any mark from MARK-NAMES. -See `guix-list-get-marked' for details." - (mapcar #'car (apply #'guix-list-get-marked mark-names))) - -(defun guix-list--mark (mark-name &optional advance &rest args) - "Put a mark on the current line. -Also add the current entry to `guix-list-marked' using its ID and ARGS. -MARK-NAME is a symbol from `guix-list-marks'. -If ADVANCE is non-nil, move forward by one line after marking." - (let ((id (guix-list-current-id))) - (if (eq mark-name 'empty) - (setq guix-list-marked (assq-delete-all id guix-list-marked)) - (let ((assoc (assq id guix-list-marked)) - (val (cons mark-name args))) - (if assoc - (setcdr assoc val) - (push (cons id val) guix-list-marked))))) - (tabulated-list-put-tag (guix-list-get-mark-string mark-name) - advance)) - -(defun guix-list-mark (&optional arg) - "Mark the current line and move to the next line. -With ARG, mark all lines." - (interactive "P") - (if arg - (guix-list-mark-all) - (guix-list--mark 'general t))) - -(defun guix-list-mark-all (&optional mark-name) - "Mark all lines with MARK-NAME mark. -MARK-NAME is a symbol from `guix-list-marks'. -Interactively, put a general mark on all lines." - (interactive) - (or mark-name (setq mark-name 'general)) - (guix-list-for-each-line #'guix-list--mark mark-name)) - -(defun guix-list-unmark (&optional arg) - "Unmark the current line and move to the next line. -With ARG, unmark all lines." - (interactive "P") - (if arg - (guix-list-unmark-all) - (guix-list--mark 'empty t))) - -(defun guix-list-unmark-backward () - "Move up one line and unmark it." - (interactive) - (forward-line -1) - (guix-list--mark 'empty)) - -(defun guix-list-unmark-all () - "Unmark all lines." - (interactive) - (guix-list-mark-all 'empty)) - -(defun guix-list-restore-marks () - "Put marks according to `guix-list-marked'." - (guix-list-for-each-line - (lambda () - (let ((mark-name (car (guix-assq-value guix-list-marked - (guix-list-current-id))))) - (tabulated-list-put-tag - (guix-list-get-mark-string (or mark-name 'empty))))))) - -(defun guix-list-sort (&optional n) - "Sort guix list entries by the column at point. -With a numeric prefix argument N, sort the Nth column. -Same as `tabulated-list-sort', but also restore marks after sorting." - (interactive "P") - (tabulated-list-sort n) - (guix-list-restore-marks)) - - -;;; Major mode and interface definer - -(defvar guix-list-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap guix-buffer-map - tabulated-list-mode-map)) - (define-key map (kbd "RET") 'guix-list-describe) - (define-key map (kbd "i") 'guix-list-describe) - (define-key map (kbd "m") 'guix-list-mark) - (define-key map (kbd "*") 'guix-list-mark) - (define-key map (kbd "u") 'guix-list-unmark) - (define-key map (kbd "DEL") 'guix-list-unmark-backward) - (define-key map [remap tabulated-list-sort] 'guix-list-sort) - map) - "Keymap for `guix-list-mode' buffers.") - -(define-derived-mode guix-list-mode tabulated-list-mode "Guix-List" - "Parent mode for displaying data in 'list' form.") - -(defun guix-list-mode-initialize (entry-type) - "Set up the current 'list' buffer for displaying ENTRY-TYPE entries." - (setq tabulated-list-padding 2 - tabulated-list-format (guix-list-tabulated-format entry-type) - tabulated-list-sort-key (guix-list-tabulated-sort-key entry-type)) - (setq-local guix-list-marks (guix-list-marks entry-type)) - (tabulated-list-init-header)) - -(defmacro guix-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Required keywords: - - - `:format' - default value of the generated - `guix-ENTRY-TYPE-list-format' variable. - -Optional keywords: - - - `:sort-key' - default value of the generated - `guix-ENTRY-TYPE-list-sort-key' variable. - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-describe-function' variable. - - - `:list-single?' - default value of the generated - `guix-ENTRY-TYPE-list-single' variable. - - - `:marks' - default value of the generated - `guix-ENTRY-TYPE-list-marks' variable. - -The rest keyword arguments are passed to -`guix-buffer-define-interface' macro." - (declare (indent 1)) - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str "-list")) - (group (intern prefix)) - (describe-var (intern (concat prefix "-describe-function"))) - (describe-count-var (intern (concat prefix - "-describe-warning-count"))) - (format-var (intern (concat prefix "-format"))) - (sort-key-var (intern (concat prefix "-sort-key"))) - (list-single-var (intern (concat prefix "-single"))) - (marks-var (intern (concat prefix "-marks")))) - (guix-keyword-args-let args - ((show-entries-val :show-entries-function) - (describe-val :describe-function) - (describe-count-val :describe-count 10) - (format-val :format) - (sort-key-val :sort-key) - (list-single-val :list-single?) - (marks-val :marks)) - `(progn - (defcustom ,format-var ,format-val - ,(format "\ -List of format values of the displayed columns. -Each element of the list has a form: - - (PARAM VALUE-FUN WIDTH SORT . PROPS) - -PARAM is a name of '%s' entry parameter. - -VALUE-FUN may be either nil or a function returning a value that -will be inserted. The function is called with 2 arguments: the -first one is the value of the parameter; the second one is an -entry (alist of parameter names and values). - -For the meaning of WIDTH, SORT and PROPS, see -`tabulated-list-format'." - entry-type-str) - :type 'sexp - :group ',group) - - (defcustom ,sort-key-var ,sort-key-val - ,(format "\ -Default sort key for 'list' buffer with '%s' entries. -Should be nil (no sort) or have a form: - - (PARAM . FLIP) - -PARAM is the name of '%s' entry parameter. For the meaning of -FLIP, see `tabulated-list-sort-key'." - entry-type-str entry-type-str) - :type '(choice (const :tag "No sort" nil) - (cons symbol boolean)) - :group ',group) - - (defvar ,marks-var ,marks-val - ,(format "\ -Alist of additional marks for 'list' buffer with '%s' entries. -Marks from this list are used along with `guix-list-default-marks'." - entry-type-str)) - - (defcustom ,list-single-var ,list-single-val - ,(format "\ -If non-nil, list '%s' entry even if it is the only matching result. -If nil, show a single '%s' entry in the 'info' buffer." - entry-type-str entry-type-str) - :type 'boolean - :group ',group) - - (defcustom ,describe-count-var ,describe-count-val - ,(format "\ -The maximum number of '%s' entries to describe without a warning. -If a user wants to describe more than this number of marked -entries, he will be prompted for confirmation. -See also `guix-list-describe'." - entry-type-str) - :type 'integer - :group ',group) - - (defvar ,describe-var ,describe-val - ,(format "Function used to describe '%s' entries." - entry-type-str)) - - (guix-alist-put! - '((describe . ,describe-var) - (describe-count . ,describe-count-var) - (format . ,format-var) - (sort-key . ,sort-key-var) - (list-single . ,list-single-var) - (marks . ,marks-var)) - 'guix-list-data ',entry-type) - - ,(if show-entries-val - `(guix-buffer-define-interface list ,entry-type - :show-entries-function ,show-entries-val - ,@%foreign-args) - - (let ((insert-fun (intern (concat prefix "-insert-entries"))) - (mode-init-fun (intern (concat prefix "-mode-initialize")))) - `(progn - (defun ,insert-fun (entries) - ,(format "\ -Print '%s' ENTRIES in the current 'list' buffer." - entry-type-str) - (guix-list-insert-entries entries ',entry-type)) - - (defun ,mode-init-fun () - ,(format "\ -Set up the current 'list' buffer for displaying '%s' entries." - entry-type-str) - (guix-list-mode-initialize ',entry-type)) - - (guix-buffer-define-interface list ,entry-type - :insert-entries-function ',insert-fun - :mode-init-function ',mode-init-fun - ,@%foreign-args)))))))) - - -(defvar guix-list-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group "guix-list-define-interface") - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-list-font-lock-keywords) - -(provide 'guix-list) - -;;; guix-list.el ends here diff --git a/emacs/guix-location.el b/emacs/guix-location.el deleted file mode 100644 index 81396b4017..0000000000 --- a/emacs/guix-location.el +++ /dev/null @@ -1,79 +0,0 @@ -;;; guix-location.el --- Package locations - -;; Copyright © 2016 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see <http://www.gnu.org/locations/>. - -;;; Commentary: - -;; This file provides the code to work with locations of Guix packages. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-read) -(require 'guix-guile) - -(defun guix-package-location (id-or-name) - "Return location of a package with ID-OR-NAME. -For the meaning of location, see `guix-find-location'." - (guix-eval-read (guix-make-guile-expression - 'package-location-string id-or-name))) - -;;;###autoload -(defun guix-find-location (location &optional directory) - "Go to LOCATION of a package. -LOCATION is a string of the form: - - \"FILE:LINE:COLUMN\" - -If FILE is relative, it is considered to be relative to -DIRECTORY (`guix-directory' by default). - -Interactively, prompt for LOCATION. With prefix argument, prompt -for DIRECTORY as well." - (interactive - (list (guix-read-package-location) - (guix-read-directory))) - (cl-multiple-value-bind (file line column) - (split-string location ":") - (find-file (expand-file-name file (or directory guix-directory))) - (when (and line column) - (let ((line (string-to-number line)) - (column (string-to-number column))) - (goto-char (point-min)) - (forward-line (- line 1)) - (move-to-column column) - (recenter 1))))) - -;;;###autoload -(defun guix-edit (id-or-name &optional directory) - "Edit (go to location of) package with ID-OR-NAME. -See `guix-find-location' for the meaning of package location and -DIRECTORY. -Interactively, with prefix argument, prompt for DIRECTORY." - (interactive - (list (guix-read-package-name) - (guix-read-directory))) - (let ((loc (guix-package-location id-or-name))) - (if loc - (guix-find-location loc directory) - (message "Couldn't find package location.")))) - -(provide 'guix-location) - -;;; guix-location.el ends here diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm deleted file mode 100644 index 040932f307..0000000000 --- a/emacs/guix-main.scm +++ /dev/null @@ -1,1163 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Information about packages and generations is passed to the elisp -;; side in the form of alists of parameters (such as ‘name’ or -;; ‘version’) and their values. - -;; ‘entries’ procedure is the “entry point” for the elisp side to get -;; information about packages and generations. - -;; Since name/version pair is not necessarily unique, we use -;; `object-address' to identify a package (for ‘id’ parameter), if -;; possible. However for the obsolete packages (that can be found in -;; installed manifest but not in a package directory), ‘id’ parameter is -;; still "name-version" string. So ‘id’ package parameter in the code -;; below is either an object-address number or a full-name string. - -;;; Code: - -(use-modules - (ice-9 vlist) - (ice-9 match) - (ice-9 popen) - (srfi srfi-1) - (srfi srfi-2) - (srfi srfi-11) - (srfi srfi-19) - (srfi srfi-26) - (guix) - (guix combinators) - (guix git-download) - (guix grafts) - (guix packages) - (guix profiles) - (guix licenses) - (guix utils) - (guix ui) - (guix scripts) - (guix scripts package) - (gnu packages) - (gnu system)) - -(define-syntax-rule (first-or-false lst) - (and (not (null? lst)) - (first lst))) - -(define (list-maybe obj) - (if (list? obj) obj (list obj))) - -(define (output+error thunk) - "Call THUNK and return 2 values: output and error output as strings." - (let ((output-port (open-output-string)) - (error-port (open-output-string))) - (with-output-to-port output-port - (lambda () (with-error-to-port error-port thunk))) - (let ((strings (list (get-output-string output-port) - (get-output-string error-port)))) - (close-output-port output-port) - (close-output-port error-port) - (apply values strings)))) - -(define (full-name->name+version spec) - "Given package specification SPEC with or without output, -return two values: name and version. For example, for SPEC -\"foo@0.9.1b:lib\", return \"foo\" and \"0.9.1b\"." - (let-values (((name version output) - (package-specification->name+version+output spec))) - (values name version))) - -(define (name+version->full-name name version) - (string-append name "@" version)) - -(define* (make-package-specification name #:optional version output) - (let ((full-name (if version - (name+version->full-name name version) - name))) - (if output - (string-append full-name ":" output) - full-name))) - -(define (manifest-entry->name+version+output entry) - (values - (manifest-entry-name entry) - (manifest-entry-version entry) - (manifest-entry-output entry))) - -(define (manifest-entry->package-specification entry) - (call-with-values - (lambda () (manifest-entry->name+version+output entry)) - make-package-specification)) - -(define (manifest-entries->package-specifications entries) - (map manifest-entry->package-specification entries)) - -(define (profile-package-specifications profile) - "Return a list of package specifications for PROFILE." - (let ((manifest (profile-manifest profile))) - (manifest-entries->package-specifications - (manifest-entries manifest)))) - -(define (profile->specifications+paths profile) - "Return a list of package specifications and paths for PROFILE. -Each element of the list is a list of the package specification and its path." - (let ((manifest (profile-manifest profile))) - (map (lambda (entry) - (list (manifest-entry->package-specification entry) - (manifest-entry-item entry))) - (manifest-entries manifest)))) - -(define (profile-difference profile1 profile2) - "Return a list of package specifications for outputs installed in PROFILE1 -and not installed in PROFILE2." - (let ((specs1 (profile-package-specifications profile1)) - (specs2 (profile-package-specifications profile2))) - (lset-difference string=? specs1 specs2))) - -(define (manifest-entries->hash-table entries) - "Return a hash table of name keys and lists of matching manifest ENTRIES." - (let ((table (make-hash-table (length entries)))) - (for-each (lambda (entry) - (let* ((key (manifest-entry-name entry)) - (ref (hash-ref table key))) - (hash-set! table key - (if ref (cons entry ref) (list entry))))) - entries) - table)) - -(define (manifest=? m1 m2) - (or (eq? m1 m2) - (equal? m1 m2))) - -(define manifest->hash-table - (let ((current-manifest #f) - (current-table #f)) - (lambda (manifest) - "Return a hash table of name keys and matching MANIFEST entries." - (unless (manifest=? manifest current-manifest) - (set! current-manifest manifest) - (set! current-table (manifest-entries->hash-table - (manifest-entries manifest)))) - current-table))) - -(define* (manifest-entries-by-name manifest name #:optional version output) - "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT." - (let ((entries (or (hash-ref (manifest->hash-table manifest) name) - '()))) - (if (or version output) - (filter (lambda (entry) - (and (or (not version) - (equal? version (manifest-entry-version entry))) - (or (not output) - (equal? output (manifest-entry-output entry))))) - entries) - entries))) - -(define (manifest-entry-by-output entries output) - "Return a manifest entry from ENTRIES matching OUTPUT." - (find (lambda (entry) - (string= output (manifest-entry-output entry))) - entries)) - -(define (fold-manifest-by-name manifest proc init) - "Fold over MANIFEST entries. -Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value -of RESULT. ENTRIES is a list of manifest entries with NAME/VERSION." - (hash-fold (lambda (name entries res) - (proc name (manifest-entry-version (car entries)) - entries res)) - init - (manifest->hash-table manifest))) - -(define* (object-transformer param-alist #:optional (params '())) - "Return procedure transforming objects into alist of parameter/value pairs. - -PARAM-ALIST is alist of available parameters (symbols) and procedures -returning values of these parameters. Each procedure is applied to -objects. - -PARAMS is list of parameters from PARAM-ALIST that should be returned by -a resulting procedure. If PARAMS is not specified or is an empty list, -use all available parameters. - -Example: - - (let* ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>)))) - (number->alist (object-transformer alist '(plus1 mul2)))) - (number->alist 8)) - => - ((plus1 . 9) (mul2 . 16)) -" - (let* ((use-all-params (null? params)) - (alist (filter-map (match-lambda - ((param . proc) - (and (or use-all-params - (memq param params)) - (cons param proc))) - (_ #f)) - param-alist))) - (lambda objects - (map (match-lambda - ((param . proc) - (cons param (apply proc objects)))) - alist)))) - -(define %manifest-entry-param-alist - `((output . ,manifest-entry-output) - (path . ,manifest-entry-item) - (dependencies . ,manifest-entry-dependencies))) - -(define manifest-entry->sexp - (object-transformer %manifest-entry-param-alist)) - -(define (manifest-entries->sexps entries) - (map manifest-entry->sexp entries)) - -(define (package-inputs-names inputs) - "Return a list of full names of the packages from package INPUTS." - (filter-map (match-lambda - ((_ (? package? package)) - (make-package-specification (package-name package) - (package-version package))) - ((_ (? package? package) output) - (make-package-specification (package-name package) - (package-version package) - output)) - (_ #f)) - inputs)) - -(define (package-license-names package) - "Return a list of license names of the PACKAGE." - (filter-map (lambda (license) - (and (license? license) - (license-name license))) - (list-maybe (package-license package)))) - -(define (package-source-names package) - "Return a list of source names (URLs) of the PACKAGE." - (let ((source (package-source package))) - (and (origin? source) - (filter-map (lambda (uri) - (cond ((string? uri) - uri) - ((git-reference? uri) - (git-reference-url uri)) - (else "Unknown source type"))) - (list-maybe (origin-uri source)))))) - -(define (package-unique? package) - "Return #t if PACKAGE is a single package with such name/version." - (match (packages-by-name (package-name package) - (package-version package)) - ((package) #t) - (_ #f))) - -(define %package-param-alist - `((id . ,object-address) - (package-id . ,object-address) - (name . ,package-name) - (version . ,package-version) - (license . ,package-license-names) - (source . ,package-source-names) - (synopsis . ,package-synopsis) - (description . ,package-description-string) - (home-url . ,package-home-page) - (outputs . ,package-outputs) - (systems . ,package-supported-systems) - (non-unique . ,(negate package-unique?)) - (inputs . ,(lambda (pkg) - (package-inputs-names - (package-inputs pkg)))) - (native-inputs . ,(lambda (pkg) - (package-inputs-names - (package-native-inputs pkg)))) - (propagated-inputs . ,(lambda (pkg) - (package-inputs-names - (package-propagated-inputs pkg)))) - (location . ,(lambda (pkg) - (location->string (package-location pkg)))))) - -(define (package-param package param) - "Return a value of a PACKAGE PARAM." - (and=> (assq-ref %package-param-alist param) - (cut <> package))) - - -;;; Finding packages. - -(define-values (package-by-address - register-package) - (let ((table (delay (fold-packages - (lambda (package table) - (vhash-consq (object-address package) - package table)) - vlist-null)))) - (values - (lambda (address) - "Return package by its object ADDRESS." - (match (vhash-assq address (force table)) - ((_ . package) package) - (_ #f))) - (lambda (package) - "Register PACKAGE by its 'object-address', so that later -'package-by-address' can be used to access it." - (let ((table* (force table))) - (set! table - (delay (vhash-consq (object-address package) - package table*)))))))) - -(define packages-by-name+version - (let ((table (delay (fold-packages - (lambda (package table) - (let ((file (location-file - (package-location package)))) - (vhash-cons (cons (package-name package) - (package-version package)) - package table))) - vlist-null)))) - (lambda (name version) - "Return packages matching NAME and VERSION." - (vhash-fold* cons '() (cons name version) (force table))))) - -(define (packages-by-full-name full-name) - (call-with-values - (lambda () (full-name->name+version full-name)) - packages-by-name+version)) - -(define (packages-by-id id) - (if (integer? id) - (let ((pkg (package-by-address id))) - (if pkg (list pkg) '())) - (packages-by-full-name id))) - -(define (id->name+version id) - (if (integer? id) - (and=> (package-by-address id) - (lambda (pkg) - (values (package-name pkg) - (package-version pkg)))) - (full-name->name+version id))) - -(define (package-by-id id) - (first-or-false (packages-by-id id))) - -(define (newest-package-by-id id) - (and=> (id->name+version id) - (lambda (name) - (first-or-false (find-best-packages-by-name name #f))))) - -(define (matching-packages predicate) - (fold-packages (lambda (pkg res) - (if (predicate pkg) - (cons pkg res) - res)) - '())) - -(define (filter-packages-by-output packages output) - (filter (lambda (package) - (member output (package-outputs package))) - packages)) - -(define* (packages-by-name name #:optional version output) - "Return a list of packages matching NAME, VERSION and OUTPUT." - (let ((packages (if version - (packages-by-name+version name version) - (matching-packages - (lambda (pkg) (string=? name (package-name pkg))))))) - (if output - (filter-packages-by-output packages output) - packages))) - -(define (manifest-entry->packages entry) - (call-with-values - (lambda () (manifest-entry->name+version+output entry)) - packages-by-name)) - -(define (packages-by-regexp regexp match-params) - "Return a list of packages matching REGEXP string. -MATCH-PARAMS is a list of parameters that REGEXP can match." - (define (package-match? package regexp) - (any (lambda (param) - (let ((val (package-param package param))) - (and (string? val) (regexp-exec regexp val)))) - match-params)) - - (let ((re (make-regexp regexp regexp/icase))) - (matching-packages (cut package-match? <> re)))) - -(define (packages-by-license license) - "Return a list of packages with LICENSE." - (matching-packages - (lambda (package) - (memq license (list-maybe (package-license package)))))) - -(define (all-available-packages) - "Return a list of all available packages." - (matching-packages (const #t))) - -(define (newest-available-packages) - "Return a list of the newest available packages." - (vhash-fold (lambda (name elem res) - (match elem - ((_ newest pkgs ...) - (cons newest res)))) - '() - (find-newest-available-packages))) - -(define (packages-from-file file) - "Return a list of packages from FILE." - (let ((package (load (canonicalize-path file)))) - (if (package? package) - (begin - (register-package package) - (list package)) - '()))) - - -;;; Making package/output patterns. - -(define (specification->package-pattern specification) - (call-with-values - (lambda () - (full-name->name+version specification)) - list)) - -(define (specification->output-pattern specification) - (call-with-values - (lambda () - (package-specification->name+version+output specification #f)) - list)) - -(define (id->package-pattern id) - (if (integer? id) - (package-by-address id) - (specification->package-pattern id))) - -(define (id->output-pattern id) - "Return an output pattern by output ID. -ID should be '<package-address>:<output>' or '<name>-<version>:<output>'." - (let-values (((name version output) - (package-specification->name+version+output id))) - (if version - (list name version output) - (list (package-by-address (string->number name)) - output)))) - -(define (specifications->package-patterns . specifications) - (map specification->package-pattern specifications)) - -(define (specifications->output-patterns . specifications) - (map specification->output-pattern specifications)) - -(define (ids->package-patterns . ids) - (map id->package-pattern ids)) - -(define (ids->output-patterns . ids) - (map id->output-pattern ids)) - -(define* (manifest-patterns-result packages res obsolete-pattern - #:optional installed-pattern) - "Auxiliary procedure for 'manifest-package-patterns' and -'manifest-output-patterns'." - (if (null? packages) - (cons (obsolete-pattern) res) - (if installed-pattern - ;; We don't need duplicates for a list of installed packages, - ;; so just take any (car) package. - (cons (installed-pattern (car packages)) res) - res))) - -(define* (manifest-package-patterns manifest #:optional obsolete-only?) - "Return a list of package patterns for MANIFEST entries. -If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only -for obsolete packages." - (fold-manifest-by-name - manifest - (lambda (name version entries res) - (manifest-patterns-result (packages-by-name name version) - res - (lambda () (list name version entries)) - (and (not obsolete-only?) - (cut list <> entries)))) - '())) - -(define* (manifest-output-patterns manifest #:optional obsolete-only?) - "Return a list of output patterns for MANIFEST entries. -If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only -for obsolete packages." - (fold (lambda (entry res) - (manifest-patterns-result (manifest-entry->packages entry) - res - (lambda () entry) - (and (not obsolete-only?) - (cut list <> entry)))) - '() - (manifest-entries manifest))) - -(define (obsolete-package-patterns manifest) - (manifest-package-patterns manifest #t)) - -(define (obsolete-output-patterns manifest) - (manifest-output-patterns manifest #t)) - - -;;; Transforming package/output patterns into alists. - -(define (obsolete-package-sexp name version entries) - "Return an alist with information about obsolete package. -ENTRIES is a list of installed manifest entries." - `((id . ,(name+version->full-name name version)) - (name . ,name) - (version . ,version) - (outputs . ,(map manifest-entry-output entries)) - (obsolete . #t) - (installed . ,(manifest-entries->sexps entries)))) - -(define (package-pattern-transformer manifest params) - "Return 'package-pattern->package-sexps' procedure." - (define package->sexp - (object-transformer %package-param-alist params)) - - (define* (sexp-by-package package #:optional - (entries (manifest-entries-by-name - manifest - (package-name package) - (package-version package)))) - (cons (cons 'installed (manifest-entries->sexps entries)) - (package->sexp package))) - - (define (->sexps pattern) - (match pattern - ((? package? package) - (list (sexp-by-package package))) - (((? package? package) entries) - (list (sexp-by-package package entries))) - ((name version entries) - (list (obsolete-package-sexp - name version entries))) - ((name version) - (let ((packages (packages-by-name name version))) - (if (null? packages) - (let ((entries (manifest-entries-by-name - manifest name version))) - (if (null? entries) - '() - (list (obsolete-package-sexp - name version entries)))) - (map sexp-by-package packages)))) - (_ '()))) - - ->sexps) - -(define (output-pattern-transformer manifest params) - "Return 'output-pattern->output-sexps' procedure." - (define package->sexp - (object-transformer (alist-delete 'id %package-param-alist) - params)) - - (define manifest-entry->sexp - (object-transformer (alist-delete 'output %manifest-entry-param-alist) - params)) - - (define* (output-sexp pkg-alist pkg-address output - #:optional entry) - (let ((entry-alist (if entry - (manifest-entry->sexp entry) - '())) - (base `((id . ,(string-append - (number->string pkg-address) - ":" output)) - (output . ,output) - (installed . ,(->bool entry))))) - (append entry-alist base pkg-alist))) - - (define (obsolete-output-sexp entry) - (let-values (((name version output) - (manifest-entry->name+version+output entry))) - (let ((base `((id . ,(make-package-specification - name version output)) - (package-id . ,(name+version->full-name name version)) - (name . ,name) - (version . ,version) - (output . ,output) - (obsolete . #t) - (installed . #t)))) - (append (manifest-entry->sexp entry) base)))) - - (define* (sexps-by-package package #:optional output - (entries (manifest-entries-by-name - manifest - (package-name package) - (package-version package)))) - ;; Assuming that PACKAGE has this OUTPUT. - (let ((pkg-alist (package->sexp package)) - (address (object-address package)) - (outputs (if output - (list output) - (package-outputs package)))) - (map (lambda (output) - (output-sexp pkg-alist address output - (manifest-entry-by-output entries output))) - outputs))) - - (define* (sexps-by-manifest-entry entry #:optional - (packages (manifest-entry->packages - entry))) - (if (null? packages) - (list (obsolete-output-sexp entry)) - (map (lambda (package) - (output-sexp (package->sexp package) - (object-address package) - (manifest-entry-output entry) - entry)) - packages))) - - (define (->sexps pattern) - (match pattern - ((? package? package) - (sexps-by-package package)) - ((package (? string? output)) - (sexps-by-package package output)) - ((? manifest-entry? entry) - (list (obsolete-output-sexp entry))) - ((package entry) - (sexps-by-manifest-entry entry (list package))) - ((name version output) - (let ((packages (packages-by-name name version output))) - (if (null? packages) - (let ((entries (manifest-entries-by-name - manifest name version output))) - (append-map (cut sexps-by-manifest-entry <>) - entries)) - (append-map (cut sexps-by-package <> output) - packages)))) - (_ '()))) - - ->sexps) - -(define (entry-type-error entry-type) - (error (format #f "Wrong entry-type '~a'" entry-type))) - -(define (search-type-error entry-type search-type) - (error (format #f "Wrong search type '~a' for entry-type '~a'" - search-type entry-type))) - -(define %pattern-transformers - `((package . ,package-pattern-transformer) - (output . ,output-pattern-transformer))) - -(define (pattern-transformer entry-type) - (assq-ref %pattern-transformers entry-type)) - -;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS) -;; as arguments; see `package/output-sexps'. -(define %patterns-makers - (let* ((apply-to-rest (lambda (proc) - (lambda (_ . rest) (apply proc rest)))) - (apply-to-first (lambda (proc) - (lambda (first . _) (proc first)))) - (manifest-package-proc (apply-to-first manifest-package-patterns)) - (manifest-output-proc (apply-to-first manifest-output-patterns)) - (regexp-proc (lambda (_ regexp params . __) - (packages-by-regexp regexp params))) - (license-proc (lambda (_ license-name) - (packages-by-license - (lookup-license license-name)))) - (location-proc (lambda (_ location) - (packages-by-location-file location))) - (file-proc (lambda (_ file) - (packages-from-file file))) - (all-proc (lambda _ (all-available-packages))) - (newest-proc (lambda _ (newest-available-packages)))) - `((package - (id . ,(apply-to-rest ids->package-patterns)) - (name . ,(apply-to-rest specifications->package-patterns)) - (installed . ,manifest-package-proc) - (obsolete . ,(apply-to-first obsolete-package-patterns)) - (regexp . ,regexp-proc) - (license . ,license-proc) - (location . ,location-proc) - (from-file . ,file-proc) - (all-available . ,all-proc) - (newest-available . ,newest-proc)) - (output - (id . ,(apply-to-rest ids->output-patterns)) - (name . ,(apply-to-rest specifications->output-patterns)) - (installed . ,manifest-output-proc) - (obsolete . ,(apply-to-first obsolete-output-patterns)) - (regexp . ,regexp-proc) - (license . ,license-proc) - (location . ,location-proc) - (from-file . ,file-proc) - (all-available . ,all-proc) - (newest-available . ,newest-proc))))) - -(define (patterns-maker entry-type search-type) - (or (and=> (assq-ref %patterns-makers entry-type) - (cut assq-ref <> search-type)) - (search-type-error entry-type search-type))) - -(define (package/output-sexps profile params entry-type - search-type search-vals) - "Return information about packages or package outputs. -See 'entry-sexps' for details." - (let* ((manifest (profile-manifest profile)) - (patterns (if (and (eq? entry-type 'output) - (eq? search-type 'profile-diff)) - (match search-vals - ((p1 p2) - (map specification->output-pattern - (profile-difference p1 p2))) - (_ '())) - (apply (patterns-maker entry-type search-type) - manifest search-vals))) - (->sexps ((pattern-transformer entry-type) manifest params))) - (append-map ->sexps patterns))) - - -;;; Getting information about generations. - -(define (generation-param-alist profile) - "Return an alist of generation parameters and procedures for PROFILE." - (let ((current (generation-number profile))) - `((id . ,identity) - (number . ,identity) - (prev-number . ,(cut previous-generation-number profile <>)) - (current . ,(cut = current <>)) - (path . ,(cut generation-file-name profile <>)) - (time . ,(lambda (gen) - (time-second (generation-time profile gen))))))) - -(define (matching-generations profile predicate) - "Return a list of PROFILE generations matching PREDICATE." - (filter predicate (profile-generations profile))) - -(define (last-generations profile number) - "Return a list of last NUMBER generations. -If NUMBER is 0 or less, return all generations." - (let ((generations (profile-generations profile)) - (number (if (<= number 0) +inf.0 number))) - (if (> (length generations) number) - (list-head (reverse generations) number) - generations))) - -(define (find-generations profile search-type search-vals) - "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS." - (case search-type - ((id) - (matching-generations profile (cut memq <> search-vals))) - ((last) - (last-generations profile (car search-vals))) - ((all) - (last-generations profile +inf.0)) - ((time) - (match search-vals - ((from to) - (matching-generations - profile - (lambda (gen) - (let ((time (time-second (generation-time profile gen)))) - (< from time to))))) - (_ '()))) - (else (search-type-error "generation" search-type)))) - -(define (generation-sexps profile params search-type search-vals) - "Return information about generations. -See 'entry-sexps' for details." - (let ((generations (find-generations profile search-type search-vals)) - (->sexp (object-transformer (generation-param-alist profile) - params))) - (map ->sexp generations))) - -(define system-generation-boot-parameters - (memoize - (lambda (profile generation) - "Return boot parameters for PROFILE's system GENERATION." - (let* ((gen-file (generation-file-name profile generation)) - (param-file (string-append gen-file "/parameters"))) - (call-with-input-file param-file read-boot-parameters))))) - -(define (system-generation-param-alist profile) - "Return an alist of system generation parameters and procedures for -PROFILE." - (append (generation-param-alist profile) - `((label . ,(lambda (gen) - (boot-parameters-label - (system-generation-boot-parameters - profile gen)))) - (root-device . ,(lambda (gen) - (boot-parameters-root-device - (system-generation-boot-parameters - profile gen)))) - (kernel . ,(lambda (gen) - (boot-parameters-kernel - (system-generation-boot-parameters - profile gen))))))) - -(define (system-generation-sexps profile params search-type search-vals) - "Return an alist with information about system generations." - (let ((generations (find-generations profile search-type search-vals)) - (->sexp (object-transformer (system-generation-param-alist profile) - params))) - (map ->sexp generations))) - - -;;; Getting package/output/generation entries (alists). - -(define (entries profile params entry-type search-type search-vals) - "Return information about entries. - -ENTRY-TYPE is a symbol defining a type of returning information. Should -be: 'package', 'output' or 'generation'. - -SEARCH-TYPE and SEARCH-VALS define how to get the information. -SEARCH-TYPE should be one of the following symbols: - -- If ENTRY-TYPE is 'package' or 'output': - 'id', 'name', 'regexp', 'all-available', 'newest-available', - 'installed', 'obsolete', 'generation'. - -- If ENTRY-TYPE is 'generation': - 'id', 'last', 'all', 'time'. - -PARAMS is a list of parameters for receiving. If it is an empty list, -get information with all available parameters, which are: - -- If ENTRY-TYPE is 'package': - 'id', 'name', 'version', 'outputs', 'license', 'synopsis', - 'description', 'home-url', 'inputs', 'native-inputs', - 'propagated-inputs', 'location', 'installed'. - -- If ENTRY-TYPE is 'output': - 'id', 'package-id', 'name', 'version', 'output', 'license', - 'synopsis', 'description', 'home-url', 'inputs', 'native-inputs', - 'propagated-inputs', 'location', 'installed', 'path', 'dependencies'. - -- If ENTRY-TYPE is 'generation': - 'id', 'number', 'prev-number', 'path', 'time'. - -Returning value is a list of alists. Each alist consists of -parameter/value pairs." - (case entry-type - ((package output) - (package/output-sexps profile params entry-type - search-type search-vals)) - ((generation) - (generation-sexps profile params - search-type search-vals)) - ((system-generation) - (system-generation-sexps profile params - search-type search-vals)) - (else (entry-type-error entry-type)))) - - -;;; Package actions. - -(define* (package->manifest-entry* package #:optional output) - (and package - (package->manifest-entry package output))) - -(define* (make-install-manifest-entries id #:optional output) - (package->manifest-entry* (package-by-id id) output)) - -(define* (make-upgrade-manifest-entries id #:optional output) - (package->manifest-entry* (newest-package-by-id id) output)) - -(define* (make-manifest-pattern id #:optional output) - "Make manifest pattern from a package ID and OUTPUT." - (let-values (((name version) - (id->name+version id))) - (and name version - (manifest-pattern - (name name) - (version version) - (output output))))) - -(define (convert-action-pattern pattern proc) - "Convert action PATTERN into a list of objects returned by PROC. -PROC is called: (PROC ID) or (PROC ID OUTPUT)." - (match pattern - ((id . outputs) - (if (null? outputs) - (let ((obj (proc id))) - (if obj (list obj) '())) - (filter-map (cut proc id <>) - outputs))) - (_ '()))) - -(define (convert-action-patterns patterns proc) - (append-map (cut convert-action-pattern <> proc) - patterns)) - -(define* (process-package-actions - profile #:key (install '()) (upgrade '()) (remove '()) - (use-substitutes? #t) dry-run?) - "Perform package actions. - -INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'. -Each pattern should have the following form: - - (ID . OUTPUTS) - -ID is an object address or a full-name of a package. -OUTPUTS is a list of package outputs (may be an empty list)." - (format #t "The process begins ...~%") - (let* ((install (append - (convert-action-patterns - install make-install-manifest-entries) - (convert-action-patterns - upgrade make-upgrade-manifest-entries))) - (remove (convert-action-patterns remove make-manifest-pattern)) - (transaction (manifest-transaction (install install) - (remove remove))) - (manifest (profile-manifest profile)) - (new-manifest (manifest-perform-transaction - manifest transaction))) - (unless (and (null? install) (null? remove)) - (parameterize ((%graft? (not dry-run?))) - (with-store store - (set-build-options store - #:print-build-trace #f - #:use-substitutes? use-substitutes?) - (show-manifest-transaction store manifest transaction - #:dry-run? dry-run?) - (build-and-use-profile store profile new-manifest - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?)))))) - -(define (delete-generations* profile generations) - "Delete GENERATIONS from PROFILE. -GENERATIONS is a list of generation numbers." - (with-store store - (delete-generations store profile generations))) - -(define (package-location-string id-or-name) - "Return a location string of a package with ID-OR-NAME." - (and=> (or (package-by-id id-or-name) - (match (packages-by-name id-or-name) - (() #f) - ((package _ ...) package))) - (compose location->string package-location))) - -(define (package-store-path package-id) - "Return a list of store directories of outputs of package PACKAGE-ID." - (match (package-by-id package-id) - (#f '()) - (package - (with-store store - (map (match-lambda - ((_ . drv) - (derivation-output-path drv))) - (derivation-outputs (package-derivation store package))))))) - -(define (package-source-derivation->store-path derivation) - "Return a store path of the package source DERIVATION." - (match (derivation-outputs derivation) - ;; Source derivation is always (("out" . derivation)). - (((_ . output-drv)) - (derivation-output-path output-drv)) - (_ #f))) - -(define (package-source-path package-id) - "Return a store file path to a source of a package PACKAGE-ID." - (and-let* ((package (package-by-id package-id)) - (source (package-source package))) - (with-store store - (package-source-derivation->store-path - (package-source-derivation store source))))) - -(define* (package-source-build-derivation package-id #:key dry-run? - (use-substitutes? #t)) - "Build source derivation of a package PACKAGE-ID." - (and-let* ((package (package-by-id package-id)) - (source (package-source package))) - (with-store store - (let* ((derivation (package-source-derivation store source)) - (derivations (list derivation))) - (set-build-options store - #:print-build-trace #f - #:use-substitutes? use-substitutes?) - (show-what-to-build store derivations - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) - (unless dry-run? - (build-derivations store derivations)) - (format #t "The source store path: ~a~%" - (package-source-derivation->store-path derivation)))))) - -(define (package-build-log-file package-id) - "Return the build log file of a package PACKAGE-ID. -Return #f if the build log is not found." - (and-let* ((package (package-by-id package-id))) - (with-store store - (let* ((derivation (package-derivation store package)) - (file (derivation-file-name derivation))) - (or (log-file store file) - ((@@ (guix scripts build) log-url) store file)))))) - - -;;; Executing guix commands - -(define (guix-command . args) - "Run 'guix ARGS ...' command." - (catch 'quit - (lambda () (apply run-guix args)) - (const #t))) - -(define (guix-command-output . args) - "Return 2 strings with 'guix ARGS ...' output and error output." - (output+error - (lambda () - (parameterize ((guix-warning-port (current-error-port))) - (apply guix-command args))))) - -(define (help-string . commands) - "Return string with 'guix COMMANDS ... --help' output." - (apply guix-command-output `(,@commands "--help"))) - -(define (pipe-guix-output guix-args command-args) - "Run 'guix GUIX-ARGS ...' command and pipe its output to a shell command -defined by COMMAND-ARGS. -Return #t if the shell command was executed successfully." - (let ((pipe (apply open-pipe* OPEN_WRITE command-args))) - (with-output-to-port pipe - (lambda () (apply guix-command guix-args))) - (zero? (status:exit-val (close-pipe pipe))))) - - -;;; Lists of packages, lint checkers, etc. - -(define (graph-type-names) - "Return a list of names of available graph node types." - (map (@ (guix graph) node-type-name) - (@ (guix scripts graph) %node-types))) - -(define (refresh-updater-names) - "Return a list of names of available refresh updater types." - (map (@ (guix upstream) upstream-updater-name) - (@ (guix scripts refresh) %updaters))) - -(define (lint-checker-names) - "Return a list of names of available lint checkers." - (map (lambda (checker) - (symbol->string ((@ (guix scripts lint) lint-checker-name) - checker))) - (@ (guix scripts lint) %checkers))) - -(define (package-names) - "Return a list of names of available packages." - (delete-duplicates - (fold-packages (lambda (pkg res) - (cons (package-name pkg) res)) - '()))) - -;; See the comment to 'guix-package-names' function in "guix-popup.el". -(define (package-names-lists) - (map list (package-names))) - - -;;; Licenses - -(define %licenses - (delay - (filter license? - (module-map (lambda (_ var) - (variable-ref var)) - (resolve-interface '(guix licenses)))))) - -(define (licenses) - (force %licenses)) - -(define (license-names) - "Return a list of names of available licenses." - (map license-name (licenses))) - -(define lookup-license - (memoize - (lambda (name) - "Return a license by its name." - (find (lambda (l) - (string=? name (license-name l))) - (licenses))))) - -(define (lookup-license-uri name) - "Return a license URI by its name." - (and=> (lookup-license name) - license-uri)) - -(define %license-param-alist - `((id . ,license-name) - (name . ,license-name) - (url . ,license-uri) - (comment . ,license-comment))) - -(define license->sexp - (object-transformer %license-param-alist)) - -(define (find-licenses search-type . search-values) - "Return a list of licenses depending on SEARCH-TYPE and SEARCH-VALUES." - (case search-type - ((id name) - (let ((names search-values)) - (filter-map lookup-license names))) - ((all) - (licenses)))) - -(define (license-entries search-type . search-values) - (map license->sexp - (apply find-licenses search-type search-values))) - - -;;; Package locations - -(define-values (packages-by-location-file - package-location-files) - (let* ((table (delay (fold-packages - (lambda (package table) - (let ((file (location-file - (package-location package)))) - (vhash-cons file package table))) - vlist-null))) - (files (delay (vhash-fold - (lambda (file _ result) - (if (member file result) - result - (cons file result))) - '() - (force table))))) - (values - (lambda (file) - "Return the (possibly empty) list of packages defined in location FILE." - (vhash-fold* cons '() file (force table))) - (lambda () - "Return the list of file names of all package locations." - (force files))))) - -(define %package-location-param-alist - `((id . ,identity) - (location . ,identity) - (number-of-packages . ,(lambda (location) - (length (packages-by-location-file location)))))) - -(define package-location->sexp - (object-transformer %package-location-param-alist)) - -(define (package-location-entries) - (map package-location->sexp (package-location-files))) diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el deleted file mode 100644 index 52436af9e4..0000000000 --- a/emacs/guix-messages.el +++ /dev/null @@ -1,247 +0,0 @@ -;;; guix-messages.el --- Minibuffer messages - -;; Copyright © 2014, 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 `guix-result-message' function used to show a -;; minibuffer message after displaying packages/generations in a -;; list/info buffer. - -;;; Code: - -(require 'cl-lib) -(require 'guix-utils) - -(defvar guix-messages - `((package - (id - ,(lambda (_ entries ids) - (guix-message-packages-by-id entries 'package ids))) - (name - ,(lambda (_ entries names) - (guix-message-packages-by-name entries 'package names))) - (license - ,(lambda (_ entries licenses) - (apply #'guix-message-packages-by-license - entries 'package licenses))) - (location - ,(lambda (_ entries locations) - (apply #'guix-message-packages-by-location - entries 'package locations))) - (from-file - (0 "No package in file '%s'." val) - (1 "Package from file '%s'." val)) - (regexp - (0 "No packages matching '%s'." val) - (1 "A single package matching '%s'." val) - (many "%d packages matching '%s'." count val)) - (all-available - (0 "No packages are available for some reason.") - (1 "A single available package (that's strange).") - (many "%d available packages." count)) - (newest-available - (0 "No packages are available for some reason.") - (1 "A single newest available package (that's strange).") - (many "%d newest available packages." count)) - (installed - (0 "No packages installed in profile '%s'." profile) - (1 "A single package installed in profile '%s'." profile) - (many "%d packages installed in profile '%s'." count profile)) - (obsolete - (0 "No obsolete packages in profile '%s'." profile) - (1 "A single obsolete package in profile '%s'." profile) - (many "%d obsolete packages in profile '%s'." count profile))) - - (output - (id - ,(lambda (_ entries ids) - (guix-message-packages-by-id entries 'output ids))) - (name - ,(lambda (_ entries names) - (guix-message-packages-by-name entries 'output names))) - (license - ,(lambda (_ entries licenses) - (apply #'guix-message-packages-by-license - entries 'output licenses))) - (location - ,(lambda (_ entries locations) - (apply #'guix-message-packages-by-location - entries 'output locations))) - (from-file - (0 "No package in file '%s'." val) - (1 "Package from file '%s'." val) - (many "Package outputs from file '%s'." val)) - (regexp - (0 "No package outputs matching '%s'." val) - (1 "A single package output matching '%s'." val) - (many "%d package outputs matching '%s'." count val)) - (all-available - (0 "No package outputs are available for some reason.") - (1 "A single available package output (that's strange).") - (many "%d available package outputs." count)) - (newest-available - (0 "No package outputs are available for some reason.") - (1 "A single newest available package output (that's strange).") - (many "%d newest available package outputs." count)) - (installed - (0 "No package outputs installed in profile '%s'." profile) - (1 "A single package output installed in profile '%s'." profile) - (many "%d package outputs installed in profile '%s'." count profile)) - (obsolete - (0 "No obsolete package outputs in profile '%s'." profile) - (1 "A single obsolete package output in profile '%s'." profile) - (many "%d obsolete package outputs in profile '%s'." count profile)) - (profile-diff - guix-message-outputs-by-diff)) - - (generation - (id - (0 "Generations not found.") - (1 "") - (many "%d generations." count)) - (last - (0 "No generations in profile '%s'." profile) - (1 "The last generation of profile '%s'." profile) - (many "%d last generations of profile '%s'." count profile)) - (all - (0 "No generations in profile '%s'." profile) - (1 "A single generation available in profile '%s'." profile) - (many "%d generations available in profile '%s'." count profile)) - (time - guix-message-generations-by-time)))) - -(defun guix-message-string-name (name) - "Return a quoted name string." - (concat "'" name "'")) - -(defun guix-message-string-entry-type (entry-type &optional plural) - "Return a string denoting an ENTRY-TYPE." - (cl-ecase entry-type - (package - (if plural "packages" "package")) - (output - (if plural "package outputs" "package output")) - (generation - (if plural "generations" "generation")))) - -(defun guix-message-string-entries (count entry-type) - "Return a string denoting the COUNT of ENTRY-TYPE entries." - (cl-case count - (0 (concat "No " - (guix-message-string-entry-type - entry-type 'plural))) - (1 (concat "A single " - (guix-message-string-entry-type - entry-type))) - (t (format "%d %s" - count - (guix-message-string-entry-type - entry-type 'plural))))) - -(defun guix-message-packages-by-id (entries entry-type ids) - "Display a message for packages or outputs searched by IDS." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (if (> count 1) - (concat "with the following IDs: " - (mapconcat #'guix-get-string ids ", ")) - (concat "with ID " (guix-get-string (car ids)))))) - (if (zerop count) - (message "%s %s. -Most likely, Guix REPL was restarted, so IDs are not actual -anymore, because they live only during the REPL process. -Try \"M-x guix-search-by-name\"." - str-beg str-end) - (message "%s %s." str-beg str-end)))) - -(defun guix-message-packages-by-name (entries entry-type names) - "Display a message for packages or outputs searched by NAMES." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (if (cdr names) - (concat "matching the following names: " - (mapconcat #'guix-message-string-name - names ", ")) - (concat "with name " - (guix-message-string-name (car names)))))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-packages-by-license (entries entry-type license) - "Display a message for packages or outputs searched by LICENSE." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (format "with license '%s'" license))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-packages-by-location (entries entry-type location) - "Display a message for packages or outputs searched by LOCATION." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count entry-type)) - (str-end (format "placed in '%s'" location))) - (message "%s %s." str-beg str-end))) - -(defun guix-message-generations-by-time (profile entries times) - "Display a message for generations searched by TIMES." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count 'generation)) - (time-beg (guix-get-time-string (car times))) - (time-end (guix-get-time-string (cadr times)))) - (message (concat "%s of profile '%s'\n" - "matching time period '%s' - '%s'.") - str-beg profile time-beg time-end))) - -(defun guix-message-outputs-by-diff (_ entries profiles) - "Display a message for outputs searched by PROFILES difference." - (let* ((count (length entries)) - (str-beg (guix-message-string-entries count 'output)) - (profile1 (car profiles)) - (profile2 (cadr profiles))) - (cl-multiple-value-bind (new old str-action) - (if (string-lessp profile2 profile1) - (list profile1 profile2 "added to") - (list profile2 profile1 "removed from")) - (message "%s %s profile '%s' comparing with profile '%s'." - str-beg str-action new old)))) - -(defun guix-result-message (profile entries entry-type - search-type search-vals) - "Display an appropriate message after displaying ENTRIES." - (let* ((type-spec (guix-assq-value guix-messages - (if (eq entry-type 'system-generation) - 'generation - entry-type) - search-type)) - (fun-or-count-spec (car type-spec))) - (if (functionp fun-or-count-spec) - (funcall fun-or-count-spec profile entries search-vals) - (let* ((count (length entries)) - (count-key (if (> count 1) 'many count)) - (msg-spec (guix-assq-value type-spec count-key)) - (msg (car msg-spec)) - (args (cdr msg-spec))) - (mapc (lambda (subst) - (setq args (cl-substitute (cdr subst) (car subst) args))) - `((count . ,count) - (val . ,(car search-vals)) - (profile . ,profile))) - (apply #'message msg args))))) - -(provide 'guix-messages) - -;;; guix-messages.el ends here diff --git a/emacs/guix-pcomplete.el b/emacs/guix-pcomplete.el deleted file mode 100644 index 785e54ef6d..0000000000 --- a/emacs/guix-pcomplete.el +++ /dev/null @@ -1,370 +0,0 @@ -;;; guix-pcomplete.el --- Functions for completing 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 completions for "guix" command that may be used in -;; `shell', `eshell' and wherever `pcomplete' works. - -;;; Code: - -(require 'pcomplete) -(require 'pcmpl-unix) -(require 'cl-lib) -(require 'guix-utils) -(require 'guix-help-vars) - - -;;; Interacting with guix - -(defcustom guix-pcomplete-guix-program (executable-find "guix") - "Name of the 'guix' program. -It is used to find guix commands, options, packages, etc." - :type 'file - :group 'pcomplete - :group 'guix) - -(defun guix-pcomplete-run-guix (&rest args) - "Run `guix-pcomplete-guix-program' with ARGS. -Insert the output to the current buffer." - (apply #'call-process - guix-pcomplete-guix-program nil t nil args)) - -(defun guix-pcomplete-run-guix-and-search (regexp &optional group - &rest args) - "Run `guix-pcomplete-guix-program' with ARGS and search for matches. -Return a list of strings matching REGEXP. -GROUP specifies a parenthesized expression used in REGEXP." - (with-temp-buffer - (apply #'guix-pcomplete-run-guix args) - (let (result) - (guix-while-search regexp - (push (match-string-no-properties group) result)) - (nreverse result)))) - -(defmacro guix-pcomplete-define-options-finder (name docstring regexp - &optional filter) - "Define function NAME to receive guix options and commands. - -The defined function takes an optional COMMAND argument. This -function will run 'guix COMMAND --help' (or 'guix --help' if -COMMAND is nil) using `guix-pcomplete-run-guix-and-search' and -return its result. - -If FILTER is specified, it should be a function. The result is -passed to this FILTER as argument and the result value of this -function call is returned." - (declare (doc-string 2) (indent 1)) - `(guix-memoized-defun ,name (&optional command) - ,docstring - (let* ((args '("--help")) - (args (if command (cons command args) args)) - (res (apply #'guix-pcomplete-run-guix-and-search - ,regexp guix-help-parse-regexp-group args))) - ,(if filter - `(funcall ,filter res) - 'res)))) - -(guix-pcomplete-define-options-finder guix-pcomplete-commands - "If COMMAND is nil, return a list of available guix commands. -If COMMAND is non-nil (it should be a string), return available -subcommands, actions, etc. for this guix COMMAND." - guix-help-parse-command-regexp) - -(guix-pcomplete-define-options-finder guix-pcomplete-long-options - "Return a list of available long options for guix COMMAND." - guix-help-parse-long-option-regexp) - -(guix-pcomplete-define-options-finder guix-pcomplete-short-options - "Return a string with available short options for guix COMMAND." - guix-help-parse-short-option-regexp - (lambda (list) - (guix-concat-strings list ""))) - -(guix-memoized-defun guix-pcomplete-all-packages () - "Return a list of all available Guix packages." - (guix-pcomplete-run-guix-and-search - guix-help-parse-package-regexp - guix-help-parse-regexp-group - "package" "--list-available")) - -(guix-memoized-defun guix-pcomplete-installed-packages (&optional profile) - "Return a list of Guix packages installed in PROFILE." - (let* ((args (and profile - (list (concat "--profile=" profile)))) - (args (append '("package" "--list-installed") args))) - (apply #'guix-pcomplete-run-guix-and-search - guix-help-parse-package-regexp - guix-help-parse-regexp-group - args))) - -(guix-memoized-defun guix-pcomplete-lint-checkers () - "Return a list of all available lint checkers." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "lint" "--list-checkers")) - -(guix-memoized-defun guix-pcomplete-graph-types () - "Return a list of all available graph types." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "graph" "--list-types")) - -(guix-memoized-defun guix-pcomplete-refresh-updaters () - "Return a list of all available refresh updater types." - (guix-pcomplete-run-guix-and-search - guix-help-parse-list-regexp - guix-help-parse-regexp-group - "refresh" "--list-updaters")) - - -;;; Completing - -(defvar guix-pcomplete-option-regexp (rx string-start "-") - "Regexp to match an option.") - -(defvar guix-pcomplete-long-option-regexp (rx string-start "--") - "Regexp to match a long option.") - -(defvar guix-pcomplete-long-option-with-arg-regexp - (rx string-start - (group "--" (one-or-more any)) "=" - (group (zero-or-more any))) - "Regexp to match a long option with its argument. -The first parenthesized group defines the option and the second -group - the argument.") - -(defvar guix-pcomplete-short-option-with-arg-regexp - (rx string-start - (group "-" (not (any "-"))) - (group (zero-or-more any))) - "Regexp to match a short option with its argument. -The first parenthesized group defines the option and the second -group - the argument.") - -(defun guix-pcomplete-match-option () - "Return non-nil, if the current argument is an option." - (pcomplete-match guix-pcomplete-option-regexp 0)) - -(defun guix-pcomplete-match-long-option () - "Return non-nil, if the current argument is a long option." - (pcomplete-match guix-pcomplete-long-option-regexp 0)) - -(defun guix-pcomplete-match-long-option-with-arg () - "Return non-nil, if the current argument is a long option with value." - (pcomplete-match guix-pcomplete-long-option-with-arg-regexp 0)) - -(defun guix-pcomplete-match-short-option-with-arg () - "Return non-nil, if the current argument is a short option with value." - (pcomplete-match guix-pcomplete-short-option-with-arg-regexp 0)) - -(defun guix-pcomplete-long-option-arg (option args) - "Return a long OPTION's argument from a list of arguments ARGS." - (let* ((re (concat "\\`" option "=\\(.*\\)")) - (args (cl-member-if (lambda (arg) - (string-match re arg)) - args)) - (cur (car args))) - (when cur - (match-string-no-properties 1 cur)))) - -(defun guix-pcomplete-short-option-arg (option args) - "Return a short OPTION's argument from a list of arguments ARGS." - (let* ((re (concat "\\`" option "\\(.*\\)")) - (args (cl-member-if (lambda (arg) - (string-match re arg)) - args)) - (cur (car args))) - (when cur - (let ((arg (match-string-no-properties 1 cur))) - (if (string= "" arg) - (cadr args) ; take the next arg - arg))))) - -(defun guix-pcomplete-complete-comma-args (entries) - "Complete comma separated arguments using ENTRIES." - (let ((index pcomplete-index)) - (while (= index pcomplete-index) - (let* ((args (if (or (guix-pcomplete-match-long-option-with-arg) - (guix-pcomplete-match-short-option-with-arg)) - (pcomplete-match-string 2 0) - (pcomplete-arg 0))) - (input (if (string-match ".*,\\(.*\\)" args) - (match-string-no-properties 1 args) - args))) - (pcomplete-here* entries input))))) - -(defun guix-pcomplete-complete-command-arg (command) - "Complete argument for guix COMMAND." - (cond - ((member command - '("archive" "build" "challenge" "edit" "environment" - "graph" "lint" "refresh" "size")) - (while t - (pcomplete-here (guix-pcomplete-all-packages)))) - (t (pcomplete-here* (pcomplete-entries))))) - -(defun guix-pcomplete-complete-option-arg (command option &optional input) - "Complete argument for COMMAND's OPTION. -INPUT is the current partially completed string." - (cl-flet ((option? (short long) - (or (string= option short) - (string= option long))) - (command? (&rest commands) - (member command commands)) - (complete (entries) - (pcomplete-here entries input nil t)) - (complete* (entries) - (pcomplete-here* entries input t))) - (cond - ((option? "-L" "--load-path") - (complete* (pcomplete-dirs))) - ((string= "--key-download" option) - (complete* guix-help-key-policies)) - - ((command? "package") - (cond - ;; For '--install[=]' and '--remove[=]', try to complete a package - ;; name (INPUT) after the "=" sign, and then the rest packages - ;; separated with spaces. - ((option? "-i" "--install") - (complete (guix-pcomplete-all-packages)) - (while (not (guix-pcomplete-match-option)) - (pcomplete-here (guix-pcomplete-all-packages)))) - ((option? "-r" "--remove") - (let* ((profile (or (guix-pcomplete-short-option-arg - "-p" pcomplete-args) - (guix-pcomplete-long-option-arg - "--profile" pcomplete-args))) - (profile (and profile (expand-file-name profile)))) - (complete (guix-pcomplete-installed-packages profile)) - (while (not (guix-pcomplete-match-option)) - (pcomplete-here (guix-pcomplete-installed-packages profile))))) - ((string= "--show" option) - (complete (guix-pcomplete-all-packages))) - ((option? "-p" "--profile") - (complete* (pcomplete-dirs))) - ((or (option? "-f" "--install-from-file") - (option? "-m" "--manifest")) - (complete* (pcomplete-entries))))) - - ((and (command? "archive" "build" "size") - (option? "-s" "--system")) - (complete* guix-help-system-types)) - - ((and (command? "build") - (or (option? "-f" "--file") - (option? "-r" "--root") - (string= "--with-source" option))) - (complete* (pcomplete-entries))) - - ((and (command? "graph") - (option? "-t" "--type")) - (complete* (guix-pcomplete-graph-types))) - - ((and (command? "environment") - (option? "-l" "--load")) - (complete* (pcomplete-entries))) - - ((and (command? "hash" "download") - (option? "-f" "--format")) - (complete* guix-help-hash-formats)) - - ((and (command? "lint") - (option? "-c" "--checkers")) - (guix-pcomplete-complete-comma-args - (guix-pcomplete-lint-checkers))) - - ((and (command? "publish") - (option? "-u" "--user")) - (complete* (pcmpl-unix-user-names))) - - ((command? "refresh") - (cond - ((option? "-s" "--select") - (complete* guix-help-refresh-subsets)) - ((option? "-t" "--type") - (guix-pcomplete-complete-comma-args - (guix-pcomplete-refresh-updaters))))) - - ((and (command? "size") - (option? "-m" "--map-file")) - (complete* (pcomplete-entries)))))) - -(defun guix-pcomplete-complete-options (command) - "Complete options (with their arguments) for guix COMMAND." - (while (guix-pcomplete-match-option) - (let ((index pcomplete-index)) - (if (guix-pcomplete-match-long-option) - - ;; Long options. - (if (guix-pcomplete-match-long-option-with-arg) - (let ((option (pcomplete-match-string 1 0)) - (arg (pcomplete-match-string 2 0))) - (guix-pcomplete-complete-option-arg - command option arg)) - - (pcomplete-here* (guix-pcomplete-long-options command)) - ;; We support '--opt arg' style (along with '--opt=arg'), - ;; because 'guix package --install/--remove' may be used this - ;; way. So try to complete an argument after the option has - ;; been completed. - (unless (guix-pcomplete-match-option) - (guix-pcomplete-complete-option-arg - command (pcomplete-arg 0 -1)))) - - ;; Short options. - (let ((arg (pcomplete-arg 0))) - (if (> (length arg) 2) - ;; Support specifying an argument after a short option without - ;; spaces (for example, '-L/tmp/foo'). - (guix-pcomplete-complete-option-arg - command - (substring-no-properties arg 0 2) - (substring-no-properties arg 2)) - (pcomplete-opt (guix-pcomplete-short-options command)) - (guix-pcomplete-complete-option-arg - command (pcomplete-arg 0 -1))))) - - ;; If there were no completions, move to the next argument and get - ;; out if the last argument is achieved. - (when (= index pcomplete-index) - (if (= pcomplete-index pcomplete-last) - (throw 'pcompleted nil) - (pcomplete-next-arg)))))) - -;;;###autoload -(defun pcomplete/guix () - "Completion for `guix'." - (let ((commands (guix-pcomplete-commands))) - (pcomplete-here* (cons "--help" commands)) - (let ((command (pcomplete-arg 'first 1))) - (when (member command commands) - (guix-pcomplete-complete-options command) - (let ((subcommands (guix-pcomplete-commands command))) - (when subcommands - (pcomplete-here* subcommands))) - (guix-pcomplete-complete-options command) - (guix-pcomplete-complete-command-arg command))))) - -(provide 'guix-pcomplete) - -;;; guix-pcomplete.el ends here diff --git a/emacs/guix-popup.el b/emacs/guix-popup.el deleted file mode 100644 index 59e98a352e..0000000000 --- a/emacs/guix-popup.el +++ /dev/null @@ -1,48 +0,0 @@ -;;; guix-popup.el --- Popup windows library - -;; 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 `guix-define-popup' macro which is just an alias -;; to `magit-define-popup'. According to the manual (info -;; "(magit-popup) Defining prefix and suffix commands") `magit-popup' -;; library will eventually be superseded by a more general library. - -;;; Code: - -(require 'magit-popup) - -(defalias 'guix-define-popup 'magit-define-popup) - -(defvar guix-popup-font-lock-keywords - (eval-when-compile - `((,(rx "(" - (group "guix-define-popup") - 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-popup-font-lock-keywords) - -(provide 'guix-popup) - -;;; guix-popup.el ends here diff --git a/emacs/guix-prettify.el b/emacs/guix-prettify.el deleted file mode 100644 index 38d72e860b..0000000000 --- a/emacs/guix-prettify.el +++ /dev/null @@ -1,210 +0,0 @@ -;;; guix-prettify.el --- Prettify Guix store file names - -;; Copyright © 2014, 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 package provides minor-mode for prettifying Guix store file -;; names — i.e., after enabling `guix-prettify-mode', -;; '/gnu/store/72f54nfp6g1hz873w8z3gfcah0h4nl9p-foo-0.1' names will be -;; replaced with '/gnu/store/…-foo-0.1' in the current buffer. There is -;; also `global-guix-prettify-mode' for global prettifying. - -;; To install, add the following to your emacs init file: -;; -;; (add-to-list 'load-path "/path/to/dir-with-guix-prettify") -;; (autoload 'guix-prettify-mode "guix-prettify" nil t) -;; (autoload 'global-guix-prettify-mode "guix-prettify" nil t) - -;; If you want to enable/disable composition after "M-x font-lock-mode", -;; use the following setting: -;; -;; (setq font-lock-extra-managed-props -;; (cons 'composition font-lock-extra-managed-props)) - -;; Credits: -;; -;; Thanks to Ludovic Courtès for the idea of this package. -;; -;; Thanks to the authors of `prettify-symbols-mode' (part of Emacs 24.4) -;; and "pretty-symbols.el" <http://github.com/drothlis/pretty-symbols> -;; for the code. It helped to write this package. - -;;; Code: - -(require 'guix-utils) - -(defgroup guix-prettify nil - "Prettify Guix store file names." - :prefix "guix-prettify-" - :group 'guix - :group 'font-lock - :group 'convenience) - -(defcustom guix-prettify-char ?… - "Character used for prettifying." - :type 'character - :group 'guix-prettify) - -(defcustom guix-prettify-decompose-force nil - "If non-nil, remove any composition. - -By default, after disabling `guix-prettify-mode', -compositions (prettifying names with `guix-prettify-char') are -removed only from strings matching `guix-prettify-regexp', so -that compositions created by other modes are left untouched. - -Set this variable to non-nil, if you want to remove any -composition unconditionally (like `prettify-symbols-mode' does). -Most likely it will do no harm and will make the process of -disabling `guix-prettify-mode' a little faster." - :type 'boolean - :group 'guix-prettify) - -(defcustom guix-prettify-regexp - ;; The following file names / URLs should be abbreviated: - - ;; /gnu/store/…-foo-0.1 - ;; /nix/store/…-foo-0.1 - ;; http://hydra.gnu.org/nar/…-foo-0.1 - ;; http://hydra.gnu.org/log/…-foo-0.1 - - (rx "/" (or "store" "nar" "log") "/" - ;; Hash-parts do not include "e", "o", "u" and "t". See base32Chars - ;; at <https://github.com/NixOS/nix/blob/master/src/libutil/hash.cc> - (group (= 32 (any "0-9" "a-d" "f-n" "p-s" "v-z")))) - "Regexp matching file names for prettifying. - -Disable `guix-prettify-mode' before modifying this variable and -make sure to modify `guix-prettify-regexp-group' if needed. - -Example of a \"deeper\" prettifying: - - (setq guix-prettify-regexp \"store/[[:alnum:]]\\\\\\={32\\\\}\" - guix-prettify-regexp-group 0) - -This will transform -'/gnu/store/72f54nfp6g1hz873w8z3gfcah0h4nl9p-foo-0.1' into -'/gnu/…-foo-0.1'" - :type 'regexp - :group 'guix-prettify) - -(defcustom guix-prettify-regexp-group 1 - "Regexp group in `guix-prettify-regexp' for prettifying." - :type 'integer - :group 'guix-prettify) - -(defvar guix-prettify-special-modes - '(guix-info-mode ibuffer-mode) - "List of special modes that support font-locking. - -By default, \\[global-guix-prettify-mode] enables prettifying in -all buffers except the ones where `font-lock-defaults' is -nil (see Info node `(elisp) Font Lock Basics'), because it may -break the existing highlighting. - -Modes from this list and all derived modes are exceptions -\(`global-guix-prettify-mode' enables prettifying there).") - -(defvar guix-prettify-flush-function - (cond ((fboundp 'font-lock-flush) #'font-lock-flush) - ((fboundp 'jit-lock-refontify) #'jit-lock-refontify)) - "Function used to refontify buffer. -This function is called without arguments after -enabling/disabling `guix-prettify-mode'. If nil, do nothing.") - -(defun guix-prettify-compose () - "Compose matching region in the current buffer." - (let ((beg (match-beginning guix-prettify-regexp-group)) - (end (match-end guix-prettify-regexp-group))) - (compose-region beg end guix-prettify-char 'decompose-region)) - ;; Return nil because we're not adding any face property. - nil) - -(defun guix-prettify-decompose-buffer () - "Remove file names compositions from the current buffer." - (with-silent-modifications - (let ((inhibit-read-only t)) - (if guix-prettify-decompose-force - (remove-text-properties (point-min) - (point-max) - '(composition nil)) - (guix-while-search guix-prettify-regexp - (remove-text-properties - (match-beginning guix-prettify-regexp-group) - (match-end guix-prettify-regexp-group) - '(composition nil))))))) - -;;;###autoload -(define-minor-mode guix-prettify-mode - "Toggle Guix Prettify mode. - -With a prefix argument ARG, enable Guix Prettify mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - -When Guix Prettify mode is enabled, hash-parts of the Guix store -file names (see `guix-prettify-regexp') are prettified, -i.e. displayed as `guix-prettify-char' character. This mode can -be enabled programmatically using hooks: - - (add-hook 'shell-mode-hook 'guix-prettify-mode) - -It is possible to enable the mode in any buffer, however not any -buffer's highlighting may survive after adding new elements to -`font-lock-keywords' (see `guix-prettify-special-modes' for -details). - -Also you can use `global-guix-prettify-mode' to enable Guix -Prettify mode for all modes that support font-locking." - :init-value nil - :lighter " …" - (let ((keywords `((,guix-prettify-regexp - (,guix-prettify-regexp-group - (guix-prettify-compose)))))) - (if guix-prettify-mode - ;; Turn on. - (font-lock-add-keywords nil keywords) - ;; Turn off. - (font-lock-remove-keywords nil keywords) - (guix-prettify-decompose-buffer)) - (and guix-prettify-flush-function - (funcall guix-prettify-flush-function)))) - -(defun guix-prettify-supported-p () - "Return non-nil, if the mode can be harmlessly enabled in current buffer." - (or font-lock-defaults - (apply #'derived-mode-p guix-prettify-special-modes))) - -(defun guix-prettify-turn-on () - "Enable `guix-prettify-mode' in the current buffer if needed. -See `guix-prettify-special-modes' for details." - (and (not guix-prettify-mode) - (guix-prettify-supported-p) - (guix-prettify-mode))) - -;;;###autoload -(define-globalized-minor-mode global-guix-prettify-mode - guix-prettify-mode guix-prettify-turn-on) - -;;;###autoload -(defalias 'guix-prettify-global-mode 'global-guix-prettify-mode) - -(provide 'guix-prettify) - -;;; guix-prettify.el ends here diff --git a/emacs/guix-profiles.el b/emacs/guix-profiles.el deleted file mode 100644 index 12cf46dbf8..0000000000 --- a/emacs/guix-profiles.el +++ /dev/null @@ -1,77 +0,0 @@ -;;; guix-profiles.el --- Guix profiles - -;; Copyright © 2014, 2015, 2016 Alex Kost <alezost@gmail.com> -;; Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org> - -;; 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/>. - -;;; Code: - -(require 'guix-config) - -(defvar guix-user-profile - (expand-file-name "~/.guix-profile") - "User profile.") - -(defvar guix-system-profile - (concat guix-config-state-directory "/profiles/system") - "System profile.") - -(defvar guix-default-profile - (concat guix-config-state-directory - "/profiles/per-user/" - (getenv "USER") - "/guix-profile") - "Default Guix profile.") - -(defvar guix-current-profile guix-default-profile - "Current profile.") - -(defvar guix-system-profile-regexp - (concat "\\`" (regexp-quote guix-system-profile)) - "Regexp matching system profiles.") - -(defun guix-system-profile? (profile) - "Return non-nil, if PROFILE is a system one." - (string-match-p guix-system-profile-regexp profile)) - -(defun guix-profile-prompt (&optional default) - "Prompt for profile and return it. -Use DEFAULT as a start directory. If it is nil, use -`guix-current-profile'." - (let* ((path (read-file-name "Profile: " - (file-name-directory - (or default guix-current-profile)))) - (path (directory-file-name (expand-file-name path)))) - (if (string= path guix-user-profile) - guix-default-profile - path))) - -(defun guix-set-current-profile (path) - "Set `guix-current-profile' to PATH. -Interactively, prompt for PATH. With prefix, use -`guix-default-profile'." - (interactive - (list (if current-prefix-arg - guix-default-profile - (guix-profile-prompt)))) - (setq guix-current-profile path) - (message "Current profile has been set to '%s'." - guix-current-profile)) - -(provide 'guix-profiles) - -;;; guix-profiles.el ends here diff --git a/emacs/guix-read.el b/emacs/guix-read.el deleted file mode 100644 index 5423c9bcfa..0000000000 --- a/emacs/guix-read.el +++ /dev/null @@ -1,147 +0,0 @@ -;;; guix-read.el --- Minibuffer readers - -;; Copyright © 2015, 2016 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 functions to prompt a user for packages, system -;; types, hash formats and other guix related stuff. - -;;; Code: - -(require 'guix-help-vars) -(require 'guix-utils) -(require 'guix-backend) -(require 'guix-guile) - - -;;; Receivable lists of packages, lint checkers, etc. - -(guix-memoized-defun guix-graph-type-names () - "Return a list of names of available graph node types." - (guix-eval-read (guix-make-guile-expression 'graph-type-names))) - -(guix-memoized-defun guix-refresh-updater-names () - "Return a list of names of available refresh updater types." - (guix-eval-read (guix-make-guile-expression 'refresh-updater-names))) - -(guix-memoized-defun guix-lint-checker-names () - "Return a list of names of available lint checkers." - (guix-eval-read (guix-make-guile-expression 'lint-checker-names))) - -(guix-memoized-defun guix-package-names () - "Return a list of names of available packages." - (sort - ;; Work around <https://github.com/jaor/geiser/issues/64>: - ;; list of strings is parsed much slower than list of lists, - ;; so we use 'package-names-lists' instead of 'package-names'. - - ;; (guix-eval-read (guix-make-guile-expression 'package-names)) - - (mapcar #'car - (guix-eval-read (guix-make-guile-expression - 'package-names-lists))) - #'string<)) - -(guix-memoized-defun guix-license-names () - "Return a list of names of available licenses." - (guix-eval-read (guix-make-guile-expression 'license-names))) - -(guix-memoized-defun guix-package-locations () - "Return a list of available package locations." - (sort (guix-eval-read (guix-make-guile-expression - 'package-location-files)) - #'string<)) - - -;;; Readers - -(guix-define-readers - :completions-var guix-help-system-types - :single-reader guix-read-system-type - :single-prompt "System type: ") - -(guix-define-readers - :completions-var guix-help-source-types - :single-reader guix-read-source-type - :single-prompt "Source type: ") - -(guix-define-readers - :completions-var guix-help-hash-formats - :single-reader guix-read-hash-format - :single-prompt "Hash format: ") - -(guix-define-readers - :completions-var guix-help-refresh-subsets - :single-reader guix-read-refresh-subset - :single-prompt "Refresh subset: ") - -(guix-define-readers - :completions-getter guix-refresh-updater-names - :multiple-reader guix-read-refresh-updater-names - :multiple-prompt "Refresh updater,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-var guix-help-key-policies - :single-reader guix-read-key-policy - :single-prompt "Key policy: ") - -(guix-define-readers - :completions-var guix-help-elpa-archives - :single-reader guix-read-elpa-archive - :single-prompt "ELPA archive: ") - -(guix-define-readers - :completions-var guix-help-verify-options - :multiple-reader guix-read-verify-options - :multiple-prompt "Verify option,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-getter guix-graph-type-names - :single-reader guix-read-graph-type - :single-prompt "Graph node type: ") - -(guix-define-readers - :completions-getter guix-lint-checker-names - :multiple-reader guix-read-lint-checker-names - :multiple-prompt "Linter,s: " - :multiple-separator ",") - -(guix-define-readers - :completions-getter guix-package-names - :single-reader guix-read-package-name - :single-prompt "Package: " - :multiple-reader guix-read-package-names - :multiple-prompt "Package,s: " - :multiple-separator " ") - -(guix-define-readers - :completions-getter guix-license-names - :single-reader guix-read-license-name - :single-prompt "License: ") - -(guix-define-readers - :completions-getter guix-package-locations - :single-reader guix-read-package-location - :single-prompt "Location: ") - -(provide 'guix-read) - -;;; guix-read.el ends here diff --git a/emacs/guix-ui-generation.el b/emacs/guix-ui-generation.el deleted file mode 100644 index 67cf6294fb..0000000000 --- a/emacs/guix-ui-generation.el +++ /dev/null @@ -1,456 +0,0 @@ -;;; guix-ui-generation.el --- Interface for displaying generations -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 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 an interface for displaying profile generations in -;; 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-ui) -(require 'guix-ui-package) -(require 'guix-base) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-profiles) - -(guix-ui-define-entry-type generation) - -(defun guix-generation-get-display (profile search-type &rest search-values) - "Search for generations and show results. - -If PROFILE is nil, use `guix-current-profile'. - -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES." - (apply #'guix-list-get-display-entries - 'generation - (or profile guix-current-profile) - search-type search-values)) - -(defun guix-delete-generations (profile generations - &optional operation-buffer) - "Delete GENERATIONS from PROFILE. -Each element from GENERATIONS is a generation number." - (when (or (not guix-operation-confirm) - (y-or-n-p - (let ((count (length generations))) - (if (> count 1) - (format "Delete %d generations from profile '%s'? " - count profile) - (format "Delete generation %d from profile '%s'? " - (car generations) profile))))) - (guix-eval-in-repl - (guix-make-guile-expression - 'delete-generations* profile generations) - operation-buffer))) - -(defun guix-switch-to-generation (profile generation - &optional operation-buffer) - "Switch PROFILE to GENERATION." - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Switch profile '%s' to generation %d? " - profile generation))) - (guix-eval-in-repl - (guix-make-guile-expression - 'switch-to-generation* profile generation) - operation-buffer))) - -(defun guix-system-generation? () - "Return non-nil, if current generation is a system one." - (eq (guix-buffer-current-entry-type) - 'system-generation)) - -(defun guix-generation-current-packages-profile (&optional generation) - "Return a directory where packages are installed for the -current profile's GENERATION." - (guix-packages-profile (guix-ui-current-profile) - generation - (guix-system-generation?))) - - -;;; Generation 'info' - -(guix-ui-info-define-interface generation - :buffer-name "*Guix Generation Info*" - :format '((number format guix-generation-info-insert-number) - (prev-number format (format)) - (current format guix-generation-info-insert-current) - (path simple (indent guix-file)) - (time format (time))) - :titles '((path . "File name") - (prev-number . "Previous number"))) - -(defface guix-generation-info-number - '((t :inherit font-lock-keyword-face)) - "Face used for a number of a generation." - :group 'guix-generation-info-faces) - -(defface guix-generation-info-current - '((t :inherit guix-package-info-installed-outputs)) - "Face used if a generation is the current one." - :group 'guix-generation-info-faces) - -(defface guix-generation-info-not-current - '((t nil)) - "Face used if a generation is not the current one." - :group 'guix-generation-info-faces) - -(defun guix-generation-info-insert-number (number &optional _) - "Insert generation NUMBER and action buttons." - (guix-info-insert-value-format number 'guix-generation-info-number) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-buffer-get-display-entries - 'list guix-package-list-type - (list (guix-generation-current-packages-profile - (button-get btn 'number)) - 'installed) - 'add)) - "Show installed packages for this generation" - 'number number) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Delete" - (lambda (btn) - (guix-delete-generations (guix-ui-current-profile) - (list (button-get btn 'number)) - (current-buffer))) - "Delete this generation" - 'number number)) - -(defun guix-generation-info-insert-current (val entry) - "Insert boolean value VAL showing whether this generation is current." - (if val - (guix-info-insert-value-format "Yes" 'guix-generation-info-current) - (guix-info-insert-value-format "No" 'guix-generation-info-not-current) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Switch" - (lambda (btn) - (guix-switch-to-generation (guix-ui-current-profile) - (button-get btn 'number) - (current-buffer))) - "Switch to this generation (make it the current one)" - 'number (guix-entry-value entry 'number)))) - - -;;; Generation 'list' - -(guix-ui-list-define-interface generation - :buffer-name "*Guix Generation List*" - :format '((number nil 5 guix-list-sort-numerically-0 :right-align t) - (current guix-generation-list-get-current 10 t) - (time guix-list-get-time 20 t) - (path guix-list-get-file-name 30 t)) - :titles '((number . "N.")) - :sort-key '(number . t) - :marks '((delete . ?D))) - -(let ((map guix-generation-list-mode-map)) - (define-key map (kbd "RET") 'guix-generation-list-show-packages) - (define-key map (kbd "+") 'guix-generation-list-show-added-packages) - (define-key map (kbd "-") 'guix-generation-list-show-removed-packages) - (define-key map (kbd "=") 'guix-generation-list-diff) - (define-key map (kbd "D") 'guix-generation-list-diff) - (define-key map (kbd "e") 'guix-generation-list-ediff) - (define-key map (kbd "x") 'guix-generation-list-execute) - (define-key map (kbd "s") 'guix-generation-list-switch) - (define-key map (kbd "c") 'guix-generation-list-switch) - (define-key map (kbd "d") 'guix-generation-list-mark-delete)) - -(defun guix-generation-list-get-current (val &optional _) - "Return string from VAL showing whether this generation is current. -VAL is a boolean value." - (if val "(current)" "")) - -(defun guix-generation-list-switch () - "Switch current profile to the generation at point." - (interactive) - (let* ((entry (guix-list-current-entry)) - (current (guix-entry-value entry 'current)) - (number (guix-entry-value entry 'number))) - (if current - (user-error "This generation is already the current one") - (guix-switch-to-generation (guix-ui-current-profile) - number (current-buffer))))) - -(defun guix-generation-list-show-packages () - "List installed packages for the generation at point." - (interactive) - (guix-package-get-display - (guix-generation-current-packages-profile (guix-list-current-id)) - 'installed)) - -(defun guix-generation-list-generations-to-compare () - "Return a sorted list of 2 marked generations for comparing." - (let ((numbers (guix-list-get-marked-id-list 'general))) - (if (/= (length numbers) 2) - (user-error "2 generations should be marked for comparing") - (sort numbers #'<)))) - -(defun guix-generation-list-profiles-to-compare () - "Return a sorted list of 2 marked generation profiles for comparing." - (mapcar #'guix-generation-current-packages-profile - (guix-generation-list-generations-to-compare))) - -(defun guix-generation-list-show-added-packages () - "List package outputs added to the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs installed in the latest marked generation that were not -installed in the other one." - (interactive) - (guix-buffer-get-display-entries - 'list 'output - (cl-list* (guix-ui-current-profile) - 'profile-diff - (reverse (guix-generation-list-profiles-to-compare))) - 'add)) - -(defun guix-generation-list-show-removed-packages () - "List package outputs removed from the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs not installed in the latest marked generation that were -installed in the other one." - (interactive) - (guix-buffer-get-display-entries - 'list 'output - (cl-list* (guix-ui-current-profile) - 'profile-diff - (guix-generation-list-profiles-to-compare)) - 'add)) - -(defun guix-generation-list-compare (diff-fun gen-fun) - "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results." - (cl-multiple-value-bind (gen1 gen2) - (guix-generation-list-generations-to-compare) - (funcall diff-fun - (funcall gen-fun gen1) - (funcall gen-fun gen2)))) - -(defun guix-generation-list-ediff-manifests () - "Run Ediff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-files - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-diff-manifests () - "Run Diff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-ediff-packages () - "Run Ediff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-buffers - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-diff-packages () - "Run Diff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-ediff (arg) - "Run Ediff on package outputs installed in the 2 marked generations. -With ARG, run Ediff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-ediff-manifests) - (guix-generation-list-ediff-packages))) - -(defun guix-generation-list-diff (arg) - "Run Diff on package outputs installed in the 2 marked generations. -With ARG, run Diff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-diff-manifests) - (guix-generation-list-diff-packages))) - -(defun guix-generation-list-mark-delete (&optional arg) - "Mark the current generation for deletion and move to the next line. -With ARG, mark all generations for deletion." - (interactive "P") - (if arg - (guix-list-mark-all 'delete) - (guix-list--mark 'delete t))) - -(defun guix-generation-list-execute () - "Delete marked generations." - (interactive) - (let ((marked (guix-list-get-marked-id-list 'delete))) - (or marked - (user-error "No generations marked for deletion")) - (guix-delete-generations (guix-ui-current-profile) - marked (current-buffer)))) - - -;;; Inserting packages to compare generations - -(defcustom guix-generation-packages-buffer-name-function - #'guix-generation-packages-buffer-name-default - "Function used to define name of a buffer with generation packages. -This function is called with 2 arguments: PROFILE (string) and -GENERATION (number)." - :type '(choice (function-item guix-generation-packages-buffer-name-default) - (function-item guix-generation-packages-buffer-name-long) - (function :tag "Other function")) - :group 'guix-generation) - -(defcustom guix-generation-packages-update-buffer t - "If non-nil, always update list of packages during comparing generations. -If nil, generation packages are received only once. So when you -compare generation 1 and generation 2, the packages for both -generations will be received. Then if you compare generation 1 -and generation 3, only the packages for generation 3 will be -received. Thus if you use comparing of different generations a -lot, you may set this variable to nil to improve the -performance." - :type 'boolean - :group 'guix-generation) - -(defvar guix-generation-output-name-width 30 - "Width of an output name \"column\". -This variable is used in auxiliary buffers for comparing generations.") - -(defun guix-generation-packages (profile) - "Return a list of sorted packages installed in PROFILE. -Each element of the list is a list of the package specification -and its store path." - (let ((names+paths (guix-eval-read - (guix-make-guile-expression - 'profile->specifications+paths profile)))) - (sort names+paths - (lambda (a b) - (string< (car a) (car b)))))) - -(defun guix-generation-packages-buffer-name-default (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use base name of PROFILE file name." - (let ((profile-name (file-name-base (directory-file-name profile)))) - (format "*Guix %s: generation %s*" - profile-name generation))) - -(defun guix-generation-packages-buffer-name-long (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use the full PROFILE file name." - (format "*Guix generation %s (%s)*" - generation profile)) - -(defun guix-generation-packages-buffer-name (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs." - (funcall guix-generation-packages-buffer-name-function - profile generation)) - -(defun guix-generation-insert-package (name path) - "Insert package output NAME and store PATH at point." - (insert name) - (indent-to guix-generation-output-name-width 2) - (insert path "\n")) - -(defun guix-generation-insert-packages (buffer profile) - "Insert package outputs installed in PROFILE in BUFFER." - (with-current-buffer buffer - (setq buffer-read-only nil - indent-tabs-mode nil) - (erase-buffer) - (mapc (lambda (name+path) - (guix-generation-insert-package - (car name+path) (cadr name+path))) - (guix-generation-packages profile)))) - -(defun guix-generation-packages-buffer (profile generation &optional system?) - "Return buffer with package outputs installed in PROFILE's GENERATION. -Create the buffer if needed." - (let ((buf-name (guix-generation-packages-buffer-name - profile generation))) - (or (and (null guix-generation-packages-update-buffer) - (get-buffer buf-name)) - (let ((buf (get-buffer-create buf-name))) - (guix-generation-insert-packages - buf - (guix-packages-profile profile generation system?)) - buf)))) - -(defun guix-profile-generation-manifest-file (generation) - "Return the file name of a GENERATION's manifest. -GENERATION is a generation number of the current profile." - (guix-manifest-file (guix-ui-current-profile) - generation - (guix-system-generation?))) - -(defun guix-profile-generation-packages-buffer (generation) - "Insert GENERATION's package outputs in a buffer and return it. -GENERATION is a generation number of the current profile." - (guix-generation-packages-buffer (guix-ui-current-profile) - generation - (guix-system-generation?))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-generations (&optional profile) - "Display information about all generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-generation-get-display profile 'all)) - -;;;###autoload -(defun guix-last-generations (number &optional profile) - "Display information about last NUMBER generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-number "The number of last generations: ") - (guix-ui-read-profile))) - (guix-generation-get-display profile 'last number)) - -;;;###autoload -(defun guix-generations-by-time (from to &optional profile) - "Display information about generations created between FROM and TO. -FROM and TO should be time values. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-date "Find generations (from): ") - (guix-read-date "Find generations (to): ") - (guix-ui-read-profile))) - (guix-generation-get-display profile 'time - (float-time from) - (float-time to))) - -(provide 'guix-ui-generation) - -;;; guix-ui-generation.el ends here diff --git a/emacs/guix-ui-license.el b/emacs/guix-ui-license.el deleted file mode 100644 index cf1b5cd357..0000000000 --- a/emacs/guix-ui-license.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; guix-ui-license.el --- Interface for displaying licenses - -;; Copyright © 2016 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 'list'/'info' interface for displaying licenses of -;; Guix packages. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-license) - -(guix-define-entry-type license) - -(defun guix-license-get-entries (search-type &rest args) - "Receive 'license' entries. -SEARCH-TYPE may be one of the following symbols: `all', `id', `name'." - (guix-eval-read - (apply #'guix-make-guile-expression - 'license-entries search-type args))) - -(defun guix-license-get-display (search-type &rest args) - "Search for licenses and show results." - (apply #'guix-list-get-display-entries - 'license search-type args)) - -(defun guix-license-message (entries search-type &rest args) - "Display a message after showing license ENTRIES." - ;; Some objects in (guix licenses) module are procedures (e.g., - ;; 'non-copyleft' or 'x11-style'). Such licenses cannot be "described". - (when (null entries) - (if (cdr args) - (message "Unknown licenses.") - (message "Unknown license.")))) - - -;;; License 'info' - -(guix-info-define-interface license - :buffer-name "*Guix License Info*" - :get-entries-function 'guix-license-get-entries - :message-function 'guix-license-message - :format '((name ignore (simple guix-info-heading)) - ignore - guix-license-insert-packages-button - (url ignore (simple guix-url)) - guix-license-insert-comment - ignore - guix-license-insert-file) - :titles '((url . "URL"))) - -(declare-function guix-packages-by-license "guix-ui-package") - -(defun guix-license-insert-packages-button (entry) - "Insert button to display packages by license ENTRY." - (let ((license (guix-entry-value entry 'name))) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-packages-by-license (button-get btn 'license))) - (format "Display packages with license '%s'" license) - 'license license))) - -(defun guix-license-insert-comment (entry) - "Insert 'comment' of a license ENTRY." - (let ((comment (guix-entry-value entry 'comment))) - (if (and comment - (string-match-p "^http" comment)) - (guix-info-insert-value-simple comment 'guix-url) - (guix-info-insert-title-simple - (guix-info-param-title 'license 'comment)) - (guix-info-insert-value-indent comment)))) - -(defun guix-license-insert-file (entry) - "Insert button to open license definition." - (let ((license (guix-entry-value entry 'name))) - (guix-insert-button - (guix-license-file) 'guix-file - 'help-echo (format "Open definition of license '%s'" license) - 'action (lambda (btn) - (guix-find-license-definition (button-get btn 'license))) - 'license license))) - - -;;; License 'list' - -(guix-list-define-interface license - :buffer-name "*Guix Licenses*" - :get-entries-function 'guix-license-get-entries - :describe-function 'guix-license-list-describe - :message-function 'guix-license-message - :format '((name nil 40 t) - (url guix-list-get-url 50 t)) - :titles '((name . "License")) - :sort-key '(name)) - -(let ((map guix-license-list-mode-map)) - (define-key map (kbd "e") 'guix-license-list-edit) - (define-key map (kbd "RET") 'guix-license-list-show-packages)) - -(defun guix-license-list-describe (ids) - "Describe licenses with IDS (list of identifiers)." - (guix-buffer-display-entries - (guix-entries-by-ids ids (guix-buffer-current-entries)) - 'info 'license (cl-list* 'id ids) 'add)) - -(defun guix-license-list-show-packages () - "Display packages with the license at point." - (interactive) - (guix-packages-by-license (guix-list-current-id))) - -(defun guix-license-list-edit (&optional directory) - "Go to the location of the current license definition. -See `guix-license-file' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-find-license-definition (guix-list-current-id) directory)) - - -;;; Interactive commands - -;;;###autoload -(defun guix-licenses () - "Display licenses of the Guix packages." - (interactive) - (guix-license-get-display 'all)) - -(provide 'guix-ui-license) - -;;; guix-ui-license.el ends here diff --git a/emacs/guix-ui-location.el b/emacs/guix-ui-location.el deleted file mode 100644 index 0027c1fba8..0000000000 --- a/emacs/guix-ui-location.el +++ /dev/null @@ -1,83 +0,0 @@ -;;; guix-ui-location.el --- Interface for displaying package locations - -;; Copyright © 2016 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 Location as published by -;; the Free Software Foundation, either version 3 of the Location, 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 Location for more details. - -;; You should have received a copy of the GNU General Public Location -;; along with this program. If not, see <http://www.gnu.org/locations/>. - -;;; Commentary: - -;; This file provides a 'list' interface for displaying locations of Guix -;; packages. - -;;; Code: - -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-location) -(require 'guix-backend) - -(guix-define-entry-type location) - -(defun guix-location-get-entries () - "Receive 'package location' entries." - (guix-eval-read "(package-location-entries)")) - - -;;; Location 'list' - -(guix-list-define-interface location - :buffer-name "*Guix Package Locations*" - :get-entries-function 'guix-location-get-entries - :format '((location guix-location-list-file-name-specification 50 t) - (number-of-packages nil 10 guix-list-sort-numerically-1 - :right-align t)) - :sort-key '(location)) - -(let ((map guix-location-list-mode-map)) - (define-key map (kbd "RET") 'guix-location-list-show-packages) - ;; "Location Info" buffer is not defined (it would be useless), so - ;; unbind "i" key (by default, it is used to display Info buffer). - (define-key map (kbd "i") nil)) - -(defun guix-location-list-file-name-specification (location &optional _) - "Return LOCATION button specification for `tabulated-list-entries'." - (list location - 'face 'guix-list-file-name - 'action (lambda (btn) - (guix-find-location (button-get btn 'location))) - 'follow-link t - 'help-echo (concat "Find location: " location) - 'location location)) - -(declare-function guix-packages-by-location "guix-ui-package") - -(defun guix-location-list-show-packages () - "Display packages placed in the location at point." - (interactive) - (guix-packages-by-location (guix-list-current-id))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-locations () - "Display locations of the Guix packages." - (interactive) - (guix-list-get-display-entries 'location)) - -(provide 'guix-ui-location) - -;;; guix-ui-location.el ends here diff --git a/emacs/guix-ui-package.el b/emacs/guix-ui-package.el deleted file mode 100644 index 4280246bb8..0000000000 --- a/emacs/guix-ui-package.el +++ /dev/null @@ -1,1191 +0,0 @@ -;;; guix-ui-package.el --- Interface for displaying packages -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 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 an interface for displaying packages and outputs -;; in 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-buffer) -(require 'guix-list) -(require 'guix-info) -(require 'guix-ui) -(require 'guix-base) -(require 'guix-backend) -(require 'guix-guile) -(require 'guix-entry) -(require 'guix-utils) -(require 'guix-hydra) -(require 'guix-hydra-build) -(require 'guix-read) -(require 'guix-license) -(require 'guix-location) -(require 'guix-profiles) - -(guix-ui-define-entry-type package) -(guix-ui-define-entry-type output) - -(defcustom guix-package-list-type 'output - "Define how to display packages in 'list' buffer. -Should be a symbol `package' or `output' (if `output', display each -output on a separate line; if `package', display each package on -a separate line)." - :type '(choice (const :tag "List of packages" package) - (const :tag "List of outputs" output)) - :group 'guix-package) - -(defcustom guix-package-info-type 'package - "Define how to display packages in 'info' buffer. -Should be a symbol `package' or `output' (if `output', display -each output separately; if `package', display outputs inside -package data)." - :type '(choice (const :tag "Display packages" package) - (const :tag "Display outputs" output)) - :group 'guix-package) - -(defun guix-package-get-display (profile search-type &rest search-values) - "Search for packages/outputs and show results. - -If PROFILE is nil, use `guix-current-profile'. - -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES. - -Results are displayed in the list buffer, unless a single package -is found and `guix-package-list-single' is nil." - (let* ((args (cl-list* (or profile guix-current-profile) - search-type search-values)) - (entries (guix-buffer-get-entries - 'list guix-package-list-type args))) - (if (or guix-package-list-single - (null entries) - (cdr entries)) - (guix-buffer-display-entries - entries 'list guix-package-list-type args 'add) - (guix-buffer-get-display-entries - 'info guix-package-info-type args 'add)))) - -(defun guix-package-entry->name-specification (entry &optional output) - "Return name specification of the package ENTRY and OUTPUT." - (guix-package-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version) - (or output (guix-entry-value entry 'output)))) - -(defun guix-package-entries->name-specifications (entries) - "Return name specifications by the package or output ENTRIES." - (cl-remove-duplicates (mapcar #'guix-package-entry->name-specification - entries) - :test #'string=)) - -(defun guix-package-installed-outputs (entry) - "Return a list of installed outputs for the package ENTRY." - (mapcar (lambda (installed-entry) - (guix-entry-value installed-entry 'output)) - (guix-entry-value entry 'installed))) - -(defun guix-package-id-and-output-by-output-id (output-id) - "Return a list (PACKAGE-ID OUTPUT) by OUTPUT-ID." - (cl-multiple-value-bind (package-id-str output) - (split-string output-id ":") - (let ((package-id (string-to-number package-id-str))) - (list (if (= 0 package-id) package-id-str package-id) - output)))) - -(defun guix-package-build-log-file (id) - "Return build log file name of a package defined by ID." - (guix-eval-read - (guix-make-guile-expression 'package-build-log-file id))) - -(defun guix-package-find-build-log (id) - "Show build log of a package defined by ID." - (require 'guix-build-log) - (let ((file (guix-package-build-log-file id))) - (if file - (guix-build-log-find-file file) - (message "Couldn't find the package build log.")))) - - -;;; Processing package actions - -(defun guix-process-package-actions (profile actions - &optional operation-buffer) - "Process package ACTIONS on PROFILE. -Each action is a list of the form: - - (ACTION-TYPE PACKAGE-SPEC ...) - -ACTION-TYPE is one of the following symbols: `install', -`upgrade', `remove'/`delete'. -PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." - (let (install upgrade remove) - (mapc (lambda (action) - (let ((action-type (car action)) - (specs (cdr action))) - (cl-case action-type - (install (setq install (append install specs))) - (upgrade (setq upgrade (append upgrade specs))) - ((remove delete) (setq remove (append remove specs)))))) - actions) - (when (guix-continue-package-operation-p - profile - :install install :upgrade upgrade :remove remove) - (guix-eval-in-repl - (guix-make-guile-expression - 'process-package-actions profile - :install install :upgrade upgrade :remove remove - :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)) - (and (not guix-dry-run) operation-buffer))))) - -(cl-defun guix-continue-package-operation-p (profile - &key install upgrade remove) - "Return non-nil if a package operation should be continued. -Ask a user if needed (see `guix-operation-confirm'). -INSTALL, UPGRADE, REMOVE are 'package action specifications'. -See `guix-process-package-actions' for details." - (or (null guix-operation-confirm) - (let* ((entries (guix-ui-get-entries - profile 'package 'id - (append (mapcar #'car install) - (mapcar #'car upgrade) - (mapcar #'car remove)) - '(id name version location))) - (install-strings (guix-get-package-strings install entries)) - (upgrade-strings (guix-get-package-strings upgrade entries)) - (remove-strings (guix-get-package-strings remove entries))) - (if (or install-strings upgrade-strings remove-strings) - (let ((buf (get-buffer-create guix-temp-buffer-name))) - (with-current-buffer buf - (setq-local cursor-type nil) - (setq buffer-read-only nil) - (erase-buffer) - (insert "Profile: " profile "\n\n") - (guix-insert-package-strings install-strings "install") - (guix-insert-package-strings upgrade-strings "upgrade") - (guix-insert-package-strings remove-strings "remove") - (let ((win (temp-buffer-window-show - buf - '((display-buffer-reuse-window - display-buffer-at-bottom) - (window-height . fit-window-to-buffer))))) - (prog1 (guix-operation-prompt) - (quit-window nil win))))) - (message "Nothing to be done. -If Guix REPL was restarted, the data is not up-to-date.") - nil)))) - -(defun guix-get-package-strings (specs entries) - "Return short package descriptions for performing package actions. -See `guix-process-package-actions' for the meaning of SPECS. -ENTRIES is a list of package entries to get info about packages." - (delq nil - (mapcar - (lambda (spec) - (let* ((id (car spec)) - (outputs (cdr spec)) - (entry (guix-entry-by-id id entries))) - (when entry - (let ((location (guix-entry-value entry 'location))) - (concat (guix-package-entry->name-specification entry) - (when outputs - (concat ":" - (guix-concat-strings outputs ","))) - (when location - (concat "\t(" location ")"))))))) - specs))) - -(defun guix-insert-package-strings (strings action) - "Insert information STRINGS at point for performing package ACTION." - (when strings - (insert "Package(s) to " (propertize action 'face 'bold) ":\n") - (mapc (lambda (str) - (insert " " str "\n")) - strings) - (insert "\n"))) - - -;;; Package 'info' - -(guix-ui-info-define-interface package - :buffer-name "*Guix Package Info*" - :format '(guix-package-info-insert-heading - ignore - (synopsis ignore (simple guix-package-info-synopsis)) - ignore - (description ignore (simple guix-package-info-description)) - ignore - (outputs simple guix-package-info-insert-outputs) - guix-package-info-insert-misc - (source simple guix-package-info-insert-source) - (location simple guix-package-info-insert-location) - (home-url format (format guix-url)) - (license format (format guix-package-license)) - (systems format guix-package-info-insert-systems) - (inputs format (format guix-package-input)) - (native-inputs format (format guix-package-native-input)) - (propagated-inputs format - (format guix-package-propagated-input))) - :titles '((home-url . "Home page") - (systems . "Supported systems")) - :required '(id name version installed non-unique)) - -(guix-info-define-interface installed-output - :format '((path simple (indent guix-file)) - (dependencies simple (indent guix-file))) - :titles '((path . "Store directory")) - :reduced? t) - -(defface guix-package-info-heading - '((t :inherit guix-info-heading)) - "Face for package name and version headings." - :group 'guix-package-info-faces) - -(defface guix-package-info-name - '((t :inherit font-lock-keyword-face)) - "Face used for a name of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-name-button - '((t :inherit button)) - "Face used for a full name that can be used to describe a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-version - '((t :inherit font-lock-builtin-face)) - "Face used for a version of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-synopsis - '((((type tty pc) (class color)) :weight bold) - (t :height 1.1 :weight bold :inherit variable-pitch)) - "Face used for a synopsis of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-description - '((t)) - "Face used for a description of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-license - '((t :inherit font-lock-string-face)) - "Face used for a license of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-location - '((t :inherit link)) - "Face used for a location of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-source - '((t :inherit link :underline nil)) - "Face used for a source URL of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-installed-outputs - '((default :weight bold) - (((class color) (min-colors 88) (background light)) - :foreground "ForestGreen") - (((class color) (min-colors 88) (background dark)) - :foreground "PaleGreen") - (((class color) (min-colors 8)) - :foreground "green") - (t :underline t)) - "Face used for installed outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-uninstalled-outputs - '((t :weight bold)) - "Face used for uninstalled outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-obsolete - '((t :inherit error)) - "Face used if a package is obsolete." - :group 'guix-package-info-faces) - -(defcustom guix-package-info-auto-find-package t - "If non-nil, open store directory after pressing \"Show\" package button. -If nil, just display the store directory (or directories) without finding." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-auto-find-source nil - "If non-nil, open source file after pressing \"Show\" source button. -If nil, just display the source file name without finding." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-auto-download-source t - "If nil, do not automatically download a source file if it doesn't exist. -After pressing a \"Show\" button, a derivation of the package -source is calculated and a store file path is displayed. If this -variable is non-nil and the source file does not exist in the -store, it will be automatically downloaded (with a possible -prompt depending on `guix-operation-confirm' variable)." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-button-functions - '(guix-package-info-insert-build-button - guix-package-info-insert-build-log-button) - "List of functions used to insert package buttons in Info buffer. -Each function is called with 2 arguments: package ID and full name." - :type '(repeat function) - :group 'guix-package-info) - -(defvar guix-package-info-download-buffer nil - "Buffer from which a current download operation was performed.") - -(defvar guix-package-info-output-format "%-10s" - "String used to format output names of the packages. -It should be a '%s'-sequence. After inserting an output name -formatted with this string, an action button is inserted.") - -(defvar guix-package-info-obsolete-string "(This package is obsolete)" - "String used if a package is obsolete.") - -(define-button-type 'guix-package-location - :supertype 'guix - 'face 'guix-package-info-location - 'help-echo "Find location of this package" - 'action (lambda (btn) - (guix-find-location (button-label btn)))) - -(define-button-type 'guix-package-license - :supertype 'guix - 'face 'guix-package-info-license - 'help-echo "Display license info" - 'action (lambda (btn) - (require 'guix-ui-license) - (guix-buffer-get-display-entries - 'info 'license - (list 'name (button-label btn)) - 'add))) - -(define-button-type 'guix-package-name - :supertype 'guix - 'face 'guix-package-info-name-button - 'help-echo "Describe this package" - 'action (lambda (btn) - (guix-buffer-get-display-entries-current - 'info guix-package-info-type - (list (guix-ui-current-profile) - 'name (or (button-get btn 'spec) - (button-label btn))) - 'add))) - -(define-button-type 'guix-package-heading - :supertype 'guix-package-name - 'face 'guix-package-info-heading) - -(define-button-type 'guix-package-source - :supertype 'guix - 'face 'guix-package-info-source - 'help-echo "" - 'action (lambda (_) - ;; As a source may not be a real URL (e.g., "mirror://..."), - ;; no action is bound to a source button. - (message "Yes, this is the source URL. What did you expect?"))) - -(defun guix-package-info-insert-heading (entry) - "Insert package ENTRY heading (name and version) at point." - (guix-insert-button - (concat (guix-entry-value entry 'name) " " - (guix-entry-value entry 'version)) - 'guix-package-heading - 'spec (guix-package-entry->name-specification entry))) - -(defun guix-package-info-insert-location (location &optional _) - "Insert package LOCATION at point." - (if (null location) - (guix-format-insert nil) - (let ((location-file (car (split-string location ":")))) - (guix-info-insert-value-indent location 'guix-package-location) - ;; Do not show "Packages" button if a package 'from file' is displayed. - (unless (eq (guix-ui-current-search-type) 'from-file) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Packages" - (lambda (btn) - (guix-package-get-display (guix-ui-current-profile) - 'location - (button-get btn 'location))) - (format "Display packages from location '%s'" location-file) - 'location location-file))))) - -(defun guix-package-info-insert-systems (systems entry) - "Insert supported package SYSTEMS at point." - (guix-info-insert-value-format - systems 'guix-hydra-build-system - 'action (lambda (btn) - (let ((args (guix-hydra-build-latest-prompt-args - :job (button-get btn 'job-name) - :system (button-label btn)))) - (apply #'guix-hydra-build-get-display - 'latest args))) - 'job-name (guix-hydra-job-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version)))) - -(defmacro guix-package-info-define-insert-inputs (&optional type) - "Define a face and a function for inserting package inputs. -TYPE is a type of inputs. -Function name is `guix-package-info-insert-TYPE-inputs'. -Face name is `guix-package-info-TYPE-inputs'." - (let* ((type-str (symbol-name type)) - (type-name (and type (concat type-str "-"))) - (type-desc (and type (concat type-str " "))) - (face (intern (concat "guix-package-info-" type-name "inputs"))) - (btn (intern (concat "guix-package-" type-name "input")))) - `(progn - (defface ,face - '((t :inherit guix-package-info-name-button)) - ,(concat "Face used for " type-desc "inputs of a package.") - :group 'guix-package-info-faces) - - (define-button-type ',btn - :supertype 'guix-package-name - 'face ',face)))) - -(guix-package-info-define-insert-inputs) -(guix-package-info-define-insert-inputs native) -(guix-package-info-define-insert-inputs propagated) - -(defun guix-package-info-insert-outputs (outputs entry) - "Insert OUTPUTS from package ENTRY at point." - (and (guix-entry-value entry 'obsolete) - (guix-package-info-insert-obsolete-text)) - (and (guix-entry-value entry 'non-unique) - (guix-entry-value entry 'installed) - (guix-package-info-insert-non-unique-text - (guix-package-entry->name-specification entry))) - (insert "\n") - (dolist (output outputs) - (guix-package-info-insert-output output entry))) - -(defun guix-package-info-insert-obsolete-text () - "Insert a message about obsolete package at point." - (guix-info-insert-indent) - (guix-format-insert guix-package-info-obsolete-string - 'guix-package-info-obsolete)) - -(defun guix-package-info-insert-non-unique-text (full-name) - "Insert a message about non-unique package with FULL-NAME at point." - (insert "\n") - (guix-info-insert-indent) - (insert "Installed outputs are displayed for a non-unique ") - (guix-insert-button full-name 'guix-package-name) - (insert " package.")) - -(defun guix-package-info-insert-output (output entry) - "Insert OUTPUT at point. -Make some fancy text with buttons and additional stuff if the -current OUTPUT is installed (if there is such output in -`installed' parameter of a package ENTRY)." - (let* ((installed (guix-entry-value entry 'installed)) - (obsolete (guix-entry-value entry 'obsolete)) - (installed-entry (cl-find-if - (lambda (entry) - (string= (guix-entry-value entry 'output) - output)) - installed)) - (action-type (if installed-entry 'delete 'install)) - (profile (guix-ui-current-profile))) - (guix-info-insert-indent) - (guix-format-insert output - (if installed-entry - 'guix-package-info-installed-outputs - 'guix-package-info-uninstalled-outputs) - guix-package-info-output-format) - ;; Do not allow a user to install/delete anything to/from a system - ;; profile, so add action buttons only for non-system profiles. - (when (and profile - (not (guix-system-profile? profile))) - (guix-package-info-insert-action-button action-type entry output) - (when obsolete - (guix-info-insert-indent) - (guix-package-info-insert-action-button 'upgrade entry output))) - (insert "\n") - (when installed-entry - (guix-info-insert-entry installed-entry 'installed-output 2)))) - -(defun guix-package-info-insert-action-button (type entry output) - "Insert button to process an action on a package OUTPUT at point. -TYPE is one of the following symbols: `install', `delete', `upgrade'. -ENTRY is an alist with package info." - (let ((type-str (capitalize (symbol-name type))) - (full-name (guix-package-entry->name-specification entry output))) - (guix-info-insert-action-button - type-str - (lambda (btn) - (guix-process-package-actions - (guix-ui-current-profile) - `((,(button-get btn 'action-type) (,(button-get btn 'id) - ,(button-get btn 'output)))) - (current-buffer))) - (concat type-str " '" full-name "'") - 'action-type type - 'id (or (guix-entry-value entry 'package-id) - (guix-entry-id entry)) - 'output output))) - -(defun guix-package-info-show-store-path (entry-id package-id) - "Show store directories of the package outputs in the current buffer. -ENTRY-ID is an ID of the current entry (package or output). -PACKAGE-ID is an ID of the package which store path to show." - (let* ((entries (guix-buffer-current-entries)) - (entry (guix-entry-by-id entry-id entries)) - (dirs (guix-package-store-path package-id))) - (or dirs - (error "Couldn't define store directory of the package")) - (let* ((new-entry (cons (cons 'store-path dirs) - entry)) - (new-entries (guix-replace-entry entry-id new-entry entries))) - (setf (guix-buffer-item-entries guix-buffer-item) - new-entries) - (guix-buffer-redisplay-goto-button) - (let ((dir (car dirs))) - (if (file-exists-p dir) - (if guix-package-info-auto-find-package - (find-file dir) - (message nil)) - (message "'%s' does not exist.\nTry to build this package." - dir)))))) - -(defun guix-package-info-insert-misc (entry) - "Insert various buttons and other info for package ENTRY at point." - (if (guix-entry-value entry 'obsolete) - (guix-format-insert nil) - (let* ((entry-id (guix-entry-id entry)) - (package-id (or (guix-entry-value entry 'package-id) - entry-id)) - (full-name (guix-package-entry->name-specification entry)) - (store-path (guix-entry-value entry 'store-path))) - (guix-info-insert-title-simple "Package") - (if store-path - (guix-info-insert-value-indent store-path 'guix-file) - (guix-info-insert-action-button - "Show" - (lambda (btn) - (guix-package-info-show-store-path - (button-get btn 'entry-id) - (button-get btn 'package-id))) - "Show the store directory of the current package" - 'entry-id entry-id - 'package-id package-id)) - (when guix-package-info-button-functions - (insert "\n") - (guix-mapinsert (lambda (fun) - (funcall fun package-id full-name)) - guix-package-info-button-functions - (guix-info-get-indent) - :indent guix-info-indent - :column (guix-info-fill-column)))))) - -(defun guix-package-info-insert-build-button (id full-name) - "Insert button to build a package defined by ID." - (guix-info-insert-action-button - "Build" - (lambda (btn) - (guix-build-package (button-get btn 'id) - (format "Build '%s' package?" full-name))) - (format "Build the current package") - 'id id)) - -(defun guix-package-info-insert-build-log-button (id _name) - "Insert button to show build log of a package defined by ID." - (guix-info-insert-action-button - "Build Log" - (lambda (btn) - (guix-package-find-build-log (button-get btn 'id))) - "View build log of the current package" - 'id id)) - -(defun guix-package-info-show-source (entry-id package-id) - "Show file name of a package source in the current info buffer. -Find the file if needed (see `guix-package-info-auto-find-source'). -ENTRY-ID is an ID of the current entry (package or output). -PACKAGE-ID is an ID of the package which source to show." - (let* ((entries (guix-buffer-current-entries)) - (entry (guix-entry-by-id entry-id entries)) - (file (guix-package-source-path package-id))) - (or file - (error "Couldn't define file name of the package source")) - (let* ((new-entry (cons (cons 'source-file file) - entry)) - (new-entries (guix-replace-entry entry-id new-entry entries))) - (setf (guix-buffer-item-entries guix-buffer-item) - new-entries) - (guix-buffer-redisplay-goto-button) - (if (file-exists-p file) - (if guix-package-info-auto-find-source - (guix-find-file file) - (message "The source store path is displayed.")) - (if guix-package-info-auto-download-source - (guix-package-info-download-source package-id) - (message "The source does not exist in the store.")))))) - -(defun guix-package-info-download-source (package-id) - "Download a source of the package PACKAGE-ID." - (setq guix-package-info-download-buffer (current-buffer)) - (guix-package-source-build-derivation - package-id - "The source does not exist in the store. Download it?")) - -(defun guix-package-info-insert-source (source entry) - "Insert SOURCE from package ENTRY at point. -SOURCE is a list of URLs." - (if (null source) - (guix-format-insert nil) - (let* ((source-file (guix-entry-value entry 'source-file)) - (entry-id (guix-entry-id entry)) - (package-id (or (guix-entry-value entry 'package-id) - entry-id))) - (if (null source-file) - (guix-info-insert-action-button - "Show" - (lambda (btn) - (guix-package-info-show-source (button-get btn 'entry-id) - (button-get btn 'package-id))) - "Show the source store directory of the current package" - 'entry-id entry-id - 'package-id package-id) - (unless (file-exists-p source-file) - (guix-info-insert-action-button - "Download" - (lambda (btn) - (guix-package-info-download-source - (button-get btn 'package-id))) - "Download the source into the store" - 'package-id package-id)) - (guix-info-insert-value-indent source-file 'guix-file)) - (guix-info-insert-value-indent source 'guix-package-source)))) - -(defun guix-package-info-redisplay-after-download () - "Redisplay an 'info' buffer after downloading the package source. -This function is used to hide a \"Download\" button if needed." - (when (buffer-live-p guix-package-info-download-buffer) - (with-current-buffer guix-package-info-download-buffer - (guix-buffer-redisplay-goto-button)) - (setq guix-package-info-download-buffer nil))) - -(add-hook 'guix-after-source-download-hook - 'guix-package-info-redisplay-after-download) - - -;;; Package 'list' - -(guix-ui-list-define-interface package - :buffer-name "*Guix Package List*" - :format '((name guix-package-list-get-name 20 t) - (version nil 10 nil) - (outputs nil 13 t) - (installed guix-package-list-get-installed-outputs 13 t) - (synopsis guix-list-get-one-line 30 nil)) - :sort-key '(name) - :marks '((install . ?I) - (upgrade . ?U) - (delete . ?D))) - -(let ((map guix-package-list-mode-map)) - (define-key map (kbd "B") 'guix-package-list-latest-builds) - (define-key map (kbd "e") 'guix-package-list-edit) - (define-key map (kbd "x") 'guix-package-list-execute) - (define-key map (kbd "i") 'guix-package-list-mark-install) - (define-key map (kbd "d") 'guix-package-list-mark-delete) - (define-key map (kbd "U") 'guix-package-list-mark-upgrade) - (define-key map (kbd "^") 'guix-package-list-mark-upgrades)) - -(defface guix-package-list-installed - '((t :inherit guix-package-info-installed-outputs)) - "Face used if there are installed outputs for the current package." - :group 'guix-package-list-faces) - -(defface guix-package-list-obsolete - '((t :inherit guix-package-info-obsolete)) - "Face used if a package is obsolete." - :group 'guix-package-list-faces) - -(defcustom guix-package-list-generation-marking-enabled nil - "If non-nil, allow putting marks in a list with 'generation packages'. - -By default this is disabled, because it may be confusing. For -example, a package is installed in some generation, so a user can -mark it for deletion in the list of packages from this -generation, but the package may not be installed in the latest -generation, so actually it cannot be deleted. - -If you managed to understand the explanation above or if you -really know what you do or if you just don't care, you can set -this variable to t. It should not do much harm anyway (most -likely)." - :type 'boolean - :group 'guix-package-list) - -(defun guix-package-list-get-name (name entry) - "Return NAME of the package ENTRY. -Colorize it with `guix-package-list-installed' or -`guix-package-list-obsolete' if needed." - (guix-get-string name - (cond ((guix-entry-value entry 'obsolete) - 'guix-package-list-obsolete) - ((guix-entry-value entry 'installed) - 'guix-package-list-installed)))) - -(defun guix-package-list-get-installed-outputs (installed &optional _) - "Return string with outputs from INSTALLED entries." - (guix-get-string - (mapcar (lambda (entry) - (guix-entry-value entry 'output)) - installed))) - -(defun guix-package-list-marking-check () - "Signal an error if marking is disabled for the current buffer." - (when (and (not guix-package-list-generation-marking-enabled) - (or (derived-mode-p 'guix-package-list-mode) - (derived-mode-p 'guix-output-list-mode)) - (eq (guix-ui-current-search-type) 'generation)) - (error "Action marks are disabled for lists of 'generation packages'"))) - -(defun guix-package-list-mark-outputs (mark default - &optional prompt available) - "Mark the current package with MARK and move to the next line. -If PROMPT is non-nil, use it to ask a user for outputs from -AVAILABLE list, otherwise mark all DEFAULT outputs." - (let ((outputs (if prompt - (guix-completing-read-multiple - prompt available nil t) - default))) - (apply #'guix-list--mark mark t outputs))) - -(defun guix-package-list-mark-install (&optional arg) - "Mark the current package for installation and move to the next line. -With ARG, prompt for the outputs to install (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (all (guix-entry-value entry 'outputs)) - (installed (guix-package-installed-outputs entry)) - (available (cl-set-difference all installed :test #'string=))) - (or available - (user-error "This package is already installed")) - (guix-package-list-mark-outputs - 'install '("out") - (and arg "Output(s) to install: ") - available))) - -(defun guix-package-list-mark-delete (&optional arg) - "Mark the current package for deletion and move to the next line. -With ARG, prompt for the outputs to delete (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-package-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (guix-package-list-mark-outputs - 'delete installed - (and arg "Output(s) to delete: ") - installed))) - -(defun guix-package-list-mark-upgrade (&optional arg) - "Mark the current package for upgrading and move to the next line. -With ARG, prompt for the outputs to upgrade (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-package-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (when (or (guix-entry-value entry 'obsolete) - (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) - (guix-package-list-mark-outputs - 'upgrade installed - (and arg "Output(s) to upgrade: ") - installed)))) - -(defun guix-package-mark-upgrades (fun) - "Mark all obsolete packages for upgrading. -Use FUN to perform marking of the current line. FUN should -take an entry as argument." - (guix-package-list-marking-check) - (let ((obsolete (cl-remove-if-not - (lambda (entry) - (guix-entry-value entry 'obsolete)) - (guix-buffer-current-entries)))) - (guix-list-for-each-line - (lambda () - (let* ((id (guix-list-current-id)) - (entry (cl-find-if - (lambda (entry) - (equal id (guix-entry-id entry))) - obsolete))) - (when entry - (funcall fun entry))))))) - -(defun guix-package-list-mark-upgrades () - "Mark all obsolete packages for upgrading." - (interactive) - (guix-package-mark-upgrades - (lambda (entry) - (apply #'guix-list--mark - 'upgrade nil - (guix-package-installed-outputs entry))))) - -(defun guix-package-assert-non-system-profile () - "Verify that the current profile is not a system one. -The current profile is the one used by the current buffer." - (let ((profile (guix-ui-current-profile))) - (and profile - (guix-system-profile? profile) - (user-error "Packages cannot be installed or removed to/from \ -profile '%s'. -Use 'guix system reconfigure' shell command to modify a system profile." - profile)))) - -(defun guix-package-execute-actions (fun) - "Perform actions on the marked packages. -Use FUN to define actions suitable for `guix-process-package-actions'. -FUN should take action-type as argument." - (guix-package-assert-non-system-profile) - (let ((actions (delq nil - (mapcar fun '(install delete upgrade))))) - (if actions - (guix-process-package-actions (guix-ui-current-profile) - actions (current-buffer)) - (user-error "No operations specified")))) - -(defun guix-package-list-execute () - "Perform actions on the marked packages." - (interactive) - (guix-package-execute-actions #'guix-package-list-make-action)) - -(defun guix-package-list-make-action (action-type) - "Return action specification for the packages marked with ACTION-TYPE. -Return nil, if there are no packages marked with ACTION-TYPE. -The specification is suitable for `guix-process-package-actions'." - (let ((specs (guix-list-get-marked-args action-type))) - (and specs (cons action-type specs)))) - -(defun guix-package-list-edit (&optional directory) - "Go to the location of the current package. -See `guix-find-location' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-edit (guix-list-current-id) directory)) - -(defun guix-package-list-latest-builds (number &rest args) - "Display latest NUMBER of Hydra builds of the current package. -Interactively, prompt for NUMBER. With prefix argument, prompt -for all ARGS." - (interactive - (let ((entry (guix-list-current-entry))) - (guix-hydra-build-latest-prompt-args - :job (guix-hydra-job-name-specification - (guix-entry-value entry 'name) - (guix-entry-value entry 'version))))) - (apply #'guix-hydra-latest-builds number args)) - - -;;; Output 'info' - -(guix-ui-info-define-interface output - :buffer-name "*Guix Package Info*" - :format '((name format (format guix-package-info-name)) - (version format guix-output-info-insert-version) - (output format guix-output-info-insert-output) - (synopsis simple (indent guix-package-info-synopsis)) - guix-package-info-insert-misc - (source simple guix-package-info-insert-source) - (path simple (indent guix-file)) - (dependencies simple (indent guix-file)) - (location simple guix-package-info-insert-location) - (home-url format (format guix-url)) - (license format (format guix-package-license)) - (systems format guix-package-info-insert-systems) - (inputs format (format guix-package-input)) - (native-inputs format (format guix-package-native-input)) - (propagated-inputs format - (format guix-package-propagated-input)) - (description simple (indent guix-package-info-description))) - :titles guix-package-info-titles - :required '(id package-id installed non-unique)) - -(defun guix-output-info-insert-version (version entry) - "Insert output VERSION and obsolete text if needed at point." - (guix-info-insert-value-format version - 'guix-package-info-version) - (and (guix-entry-value entry 'obsolete) - (guix-package-info-insert-obsolete-text))) - -(defun guix-output-info-insert-output (output entry) - "Insert OUTPUT and action buttons at point." - (let* ((installed (guix-entry-value entry 'installed)) - (obsolete (guix-entry-value entry 'obsolete)) - (action-type (if installed 'delete 'install))) - (guix-info-insert-value-format - output - (if installed - 'guix-package-info-installed-outputs - 'guix-package-info-uninstalled-outputs)) - (guix-info-insert-indent) - (guix-package-info-insert-action-button action-type entry output) - (when obsolete - (guix-info-insert-indent) - (guix-package-info-insert-action-button 'upgrade entry output)))) - - -;;; Output 'list' - -(guix-ui-list-define-interface output - :buffer-name "*Guix Package List*" - :describe-function 'guix-output-list-describe - :format '((name guix-package-list-get-name 20 t) - (version nil 10 nil) - (output nil 9 t) - (installed nil 12 t) - (synopsis guix-list-get-one-line 30 nil)) - :required '(id package-id) - :sort-key '(name) - :marks '((install . ?I) - (upgrade . ?U) - (delete . ?D))) - -(let ((map guix-output-list-mode-map)) - (define-key map (kbd "B") 'guix-package-list-latest-builds) - (define-key map (kbd "e") 'guix-output-list-edit) - (define-key map (kbd "x") 'guix-output-list-execute) - (define-key map (kbd "i") 'guix-output-list-mark-install) - (define-key map (kbd "d") 'guix-output-list-mark-delete) - (define-key map (kbd "U") 'guix-output-list-mark-upgrade) - (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) - -(defun guix-output-list-mark-install () - "Mark the current output for installation and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (if installed - (user-error "This output is already installed") - (guix-list--mark 'install t)))) - -(defun guix-output-list-mark-delete () - "Mark the current output for deletion and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (if installed - (guix-list--mark 'delete t) - (user-error "This output is not installed")))) - -(defun guix-output-list-mark-upgrade () - "Mark the current output for upgrading and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-entry-value entry 'installed))) - (or installed - (user-error "This output is not installed")) - (when (or (guix-entry-value entry 'obsolete) - (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) - (guix-list--mark 'upgrade t)))) - -(defun guix-output-list-mark-upgrades () - "Mark all obsolete package outputs for upgrading." - (interactive) - (guix-package-mark-upgrades - (lambda (_) (guix-list--mark 'upgrade)))) - -(defun guix-output-list-execute () - "Perform actions on the marked outputs." - (interactive) - (guix-package-execute-actions #'guix-output-list-make-action)) - -(defun guix-output-list-make-action (action-type) - "Return action specification for the outputs marked with ACTION-TYPE. -Return nil, if there are no outputs marked with ACTION-TYPE. -The specification is suitable for `guix-process-output-actions'." - (let ((ids (guix-list-get-marked-id-list action-type))) - (and ids (cons action-type - (mapcar #'guix-package-id-and-output-by-output-id - ids))))) - -(defun guix-output-list-describe (ids) - "Describe outputs with IDS (list of output identifiers). -See `guix-package-info-type'." - (if (eq guix-package-info-type 'output) - (guix-buffer-get-display-entries - 'info 'output - (cl-list* (guix-ui-current-profile) 'id ids) - 'add) - (let ((pids (mapcar (lambda (oid) - (car (guix-package-id-and-output-by-output-id - oid))) - ids))) - (guix-buffer-get-display-entries - 'info 'package - (cl-list* (guix-ui-current-profile) - 'id (cl-remove-duplicates pids)) - 'add)))) - -(defun guix-output-list-edit (&optional directory) - "Go to the location of the current package. -See `guix-find-location' for the meaning of DIRECTORY." - (interactive (list (guix-read-directory))) - (guix-edit (guix-entry-value (guix-list-current-entry) - 'package-id) - directory)) - - -;;; Interactive commands - -(defvar guix-package-search-params '(name synopsis description) - "Default list of package parameters for searching by regexp.") - -(defvar guix-package-search-history nil - "A history of minibuffer prompts.") - -;;;###autoload -(defun guix-packages-by-name (name &optional profile) - "Display Guix packages with NAME. -NAME is a string with name specification. It may optionally contain -a version number. Examples: \"guile\", \"guile@2.0.11\". - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-package-name) - (guix-ui-read-profile))) - (guix-package-get-display profile 'name name)) - -;;;###autoload -(defun guix-packages-by-license (license &optional profile) - "Display Guix packages with LICENSE. -LICENSE is a license name string. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-license-name) - (guix-ui-read-profile))) - (guix-package-get-display profile 'license license)) - -;;;###autoload -(defun guix-packages-by-location (location &optional profile) - "Display Guix packages placed in LOCATION file. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-package-location) - (guix-ui-read-profile))) - (guix-package-get-display profile 'location location)) - -;;;###autoload -(defun guix-package-from-file (file &optional profile) - "Display Guix package that the code from FILE evaluates to. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-file-name "File with package: ") - (guix-ui-read-profile))) - (guix-buffer-get-display-entries - 'info 'package - (list (or profile guix-current-profile) 'from-file file) - 'add)) - -;;;###autoload -(defun guix-search-by-regexp (regexp &optional params profile) - "Search for Guix packages by REGEXP. -PARAMS are package parameters that should be searched. -If PARAMS are not specified, use `guix-package-search-params'. - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-regexp "Regexp: " nil 'guix-package-search-history) - nil (guix-ui-read-profile))) - (guix-package-get-display profile 'regexp regexp - (or params guix-package-search-params))) - -;;;###autoload -(defun guix-search-by-name (regexp &optional profile) - "Search for Guix packages matching REGEXP in a package name. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-string "Package name by regexp: " - nil 'guix-package-search-history) - (guix-ui-read-profile))) - (guix-search-by-regexp regexp '(name) profile)) - -;;;###autoload -(defun guix-installed-packages (&optional profile) - "Display information about installed Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'installed)) - -;;;###autoload -(defun guix-installed-user-packages () - "Display information about Guix packages installed in a user profile." - (interactive) - (guix-installed-packages guix-user-profile)) - -;;;###autoload -(defun guix-installed-system-packages () - "Display information about Guix packages installed in a system profile." - (interactive) - (guix-installed-packages - (guix-packages-profile guix-system-profile nil t))) - -;;;###autoload -(defun guix-obsolete-packages (&optional profile) - "Display information about obsolete Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'obsolete)) - -;;;###autoload -(defun guix-all-available-packages (&optional profile) - "Display information about all available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'all-available)) - -;;;###autoload -(defun guix-newest-available-packages (&optional profile) - "Display information about the newest available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive (list (guix-ui-read-profile))) - (guix-package-get-display profile 'newest-available)) - -(provide 'guix-ui-package) - -;;; guix-ui-package.el ends here diff --git a/emacs/guix-ui-system-generation.el b/emacs/guix-ui-system-generation.el deleted file mode 100644 index 7f4d76d489..0000000000 --- a/emacs/guix-ui-system-generation.el +++ /dev/null @@ -1,105 +0,0 @@ -;;; guix-ui-system-generation.el --- Interface for displaying system generations -*- lexical-binding: t -*- - -;; Copyright © 2016 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 an interface for displaying system generations -;; in 'list' and 'info' buffers, and commands for working with them. - -;;; Code: - -(require 'cl-lib) -(require 'guix-list) -(require 'guix-ui) -(require 'guix-ui-generation) -(require 'guix-profiles) - -(guix-ui-define-entry-type system-generation) - -(defun guix-system-generation-get-display (search-type &rest search-values) - "Search for system generations and show results. -See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALUES." - (apply #'guix-list-get-display-entries - 'system-generation - guix-system-profile - search-type search-values)) - - -;;; System generation 'info' - -(guix-ui-info-define-interface system-generation - :buffer-name "*Guix Generation Info*" - :format '((number format guix-generation-info-insert-number) - (label format (format)) - (prev-number format (format)) - (current format guix-generation-info-insert-current) - (path format (format guix-file)) - (time format (time)) - (root-device format (format)) - (kernel format (format guix-file))) - :titles guix-generation-info-titles) - - -;;; System generation 'list' - -;; FIXME It is better to make `guix-generation-list-shared-map' with -;; common keys for both usual and system generations. -(defvar guix-system-generation-list-mode-map - (copy-keymap guix-generation-list-mode-map) - "Keymap for `guix-system-generation-list-mode' buffers.") - -(guix-ui-list-define-interface system-generation - :buffer-name "*Guix Generation List*" - :format '((number nil 5 guix-list-sort-numerically-0 :right-align t) - (current guix-generation-list-get-current 10 t) - (label nil 40 t) - (time guix-list-get-time 20 t) - (path guix-list-get-file-name 30 t)) - :titles guix-generation-list-titles - :sort-key '(number . t) - :marks '((delete . ?D))) - - -;;; Interactive commands - -;;;###autoload -(defun guix-system-generations () - "Display information about system generations." - (interactive) - (guix-system-generation-get-display 'all)) - -;;;###autoload -(defun guix-last-system-generations (number) - "Display information about last NUMBER of system generations." - (interactive "nThe number of last generations: ") - (guix-system-generation-get-display 'last number)) - -;;;###autoload -(defun guix-system-generations-by-time (from to) - "Display information about system generations created between FROM and TO." - (interactive - (list (guix-read-date "Find generations (from): ") - (guix-read-date "Find generations (to): "))) - (guix-system-generation-get-display - 'time (float-time from) (float-time to))) - -(provide 'guix-ui-system-generation) - -;;; guix-ui-system-generation.el ends here diff --git a/emacs/guix-ui.el b/emacs/guix-ui.el deleted file mode 100644 index 1b696314cd..0000000000 --- a/emacs/guix-ui.el +++ /dev/null @@ -1,323 +0,0 @@ -;;; guix-ui.el --- Common code for Guix package management interface -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 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 some general code for 'list'/'info' interfaces for -;; packages and generations. - -;;; Code: - -(require 'cl-lib) -(require 'guix-backend) -(require 'guix-buffer) -(require 'guix-guile) -(require 'guix-utils) -(require 'guix-messages) -(require 'guix-profiles) - -(guix-define-groups ui - :group-doc "\ -Settings for 'ui' (Guix package management) buffers. -This group includes settings for displaying packages, outputs and -generations in 'list' and 'info' buffers.") - -(defvar guix-ui-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "M") 'guix-apply-manifest) - (define-key map (kbd "C-c C-z") 'guix-switch-to-repl) - map) - "Parent keymap for Guix package/generation buffers.") - -(guix-buffer-define-current-args-accessors - "guix-ui-current" "profile" "search-type" "search-values") - -(defun guix-ui-read-profile () - "Return `guix-current-profile' or prompt for it. -This function is intended for using in `interactive' forms." - (if current-prefix-arg - (guix-profile-prompt) - guix-current-profile)) - -(defun guix-ui-get-entries (profile entry-type search-type search-values - &optional params) - "Receive ENTRY-TYPE entries for PROFILE. -Call an appropriate scheme procedure and return a list of entries. - -ENTRY-TYPE should be one of the following symbols: `package', -`output' or `generation'. - -SEARCH-TYPE may be one of the following symbols: - -- If ENTRY-TYPE is `package' or `output': `id', `name', `regexp', - `all-available', `newest-available', `installed', `obsolete', - `generation'. - -- If ENTRY-TYPE is `generation': `id', `last', `all', `time'. - -PARAMS is a list of parameters for receiving. If nil, get data -with all available parameters." - (guix-eval-read - (guix-make-guile-expression - 'entries - profile params entry-type search-type search-values))) - -(defun guix-ui-list-describe (ids) - "Describe 'ui' entries with IDS (list of identifiers)." - (guix-buffer-get-display-entries - 'info (guix-buffer-current-entry-type) - (cl-list* (guix-ui-current-profile) 'id ids) - 'add)) - - -;;; Buffers and auto updating - -(defcustom guix-ui-update-after-operation 'current - "Define what kind of data to update after executing an operation. - -After successful executing an operation in the Guix REPL (for -example after installing a package), the data in Guix buffers -will or will not be automatically updated depending on a value of -this variable. - -If nil, update nothing (do not revert any buffer). -If `current', update the buffer from which an operation was performed. -If `all', update all Guix buffers (not recommended)." - :type '(choice (const :tag "Do nothing" nil) - (const :tag "Update operation buffer" current) - (const :tag "Update all Guix buffers" all)) - :group 'guix-ui) - -(defcustom guix-ui-buffer-name-function - #'guix-ui-buffer-name-full - "Function used to define a name of a Guix buffer. -The function is called with 2 arguments: BASE-NAME and PROFILE." - :type '(choice (function-item guix-ui-buffer-name-full) - (function-item guix-ui-buffer-name-short) - (function-item guix-ui-buffer-name-simple) - (function :tag "Other function")) - :group 'guix-ui) - -(defun guix-ui-buffer-name-simple (base-name &rest _) - "Return BASE-NAME." - base-name) - -(defun guix-ui-buffer-name-short (base-name profile) - "Return buffer name by appending BASE-NAME and PROFILE's base file name." - (guix-compose-buffer-name base-name - (file-name-base (directory-file-name profile)))) - -(defun guix-ui-buffer-name-full (base-name profile) - "Return buffer name by appending BASE-NAME and PROFILE's full name." - (guix-compose-buffer-name base-name profile)) - -(defun guix-ui-buffer-name (base-name profile) - "Return Guix buffer name based on BASE-NAME and profile. -See `guix-ui-buffer-name-function' for details." - (funcall guix-ui-buffer-name-function - base-name profile)) - -(defun guix-ui-buffer? (&optional buffer modes) - "Return non-nil if BUFFER mode is derived from any of the MODES. -If BUFFER is nil, check current buffer. -If MODES is nil, use `guix-list-mode' and `guix-info-mode'." - (with-current-buffer (or buffer (current-buffer)) - (apply #'derived-mode-p - (or modes '(guix-list-mode guix-info-mode))))) - -(defun guix-ui-buffers (&optional modes) - "Return a list of all buffers with major modes derived from MODES. -If MODES is nil, return list of all Guix 'list' and 'info' buffers." - (cl-remove-if-not (lambda (buf) - (guix-ui-buffer? buf modes)) - (buffer-list))) - -(defun guix-ui-update-buffer (buffer) - "Update data in a 'list' or 'info' BUFFER." - (with-current-buffer buffer - (guix-buffer-revert nil t))) - -(defun guix-ui-update-buffers-after-operation () - "Update buffers after Guix operation if needed. -See `guix-ui-update-after-operation' for details." - (let ((to-update - (and guix-operation-buffer - (cl-case guix-ui-update-after-operation - (current (and (buffer-live-p guix-operation-buffer) - (guix-ui-buffer? guix-operation-buffer) - (list guix-operation-buffer))) - (all (guix-ui-buffers)))))) - (setq guix-operation-buffer nil) - (mapc #'guix-ui-update-buffer to-update))) - -(add-hook 'guix-after-repl-operation-hook - 'guix-ui-update-buffers-after-operation) - - -;;; Interface definers - -(defmacro guix-ui-define-entry-type (entry-type &rest args) - "Define general code for ENTRY-TYPE. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -The rest keyword arguments are passed to -`guix-define-entry-type' macro." - (declare (indent 1)) - `(guix-define-entry-type ,entry-type - :parent-group guix-ui - :parent-faces-group guix-ui-faces - ,@args)) - -(defmacro guix-ui-define-interface (buffer-type entry-type &rest args) - "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... -In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. - -Required keywords: - - - `:buffer-name' - base part of a buffer name. It is used in a - generated `guix-TYPE-buffer-name' function; see - `guix-ui-buffer-name' for details. - -Optional keywords: - - - `:required' - default value of the generated - `guix-TYPE-required-params' variable. - -The rest keyword arguments are passed to -`guix-BUFFER-TYPE-define-interface' macro. - -Along with the mentioned definitions, this macro also defines: - - - `guix-TYPE-mode-map' - keymap based on `guix-ui-map' and - `guix-BUFFER-TYPE-mode-map'. - - - `guix-TYPE-get-entries' - a wrapper around `guix-ui-get-entries'. - - - `guix-TYPE-message' - a wrapper around `guix-result-message'." - (declare (indent 2)) - (let* ((entry-type-str (symbol-name entry-type)) - (buffer-type-str (symbol-name buffer-type)) - (prefix (concat "guix-" entry-type-str "-" - buffer-type-str)) - (mode-str (concat prefix "-mode")) - (mode-map (intern (concat mode-str "-map"))) - (parent-map (intern (format "guix-%s-mode-map" - buffer-type-str))) - (required-var (intern (concat prefix "-required-params"))) - (buffer-name-fun (intern (concat prefix "-buffer-name"))) - (get-fun (intern (concat prefix "-get-entries"))) - (message-fun (intern (concat prefix "-message"))) - (displayed-fun (intern (format "guix-%s-displayed-params" - buffer-type-str))) - (definer (intern (format "guix-%s-define-interface" - buffer-type-str)))) - (guix-keyword-args-let args - ((buffer-name-val :buffer-name) - (required-val :required ''(id))) - `(progn - (defvar ,mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent - map (make-composed-keymap ,parent-map guix-ui-map)) - map) - ,(format "Keymap for `%s' buffers." mode-str)) - - (defvar ,required-var ,required-val - ,(format "\ -List of the required '%s' parameters. -These parameters are received by `%S' -along with the displayed parameters. - -Do not remove `id' from this list as it is required for -identifying an entry." - entry-type-str get-fun)) - - (defun ,buffer-name-fun (profile &rest _) - ,(format "\ -Return a name of '%s' buffer for displaying '%s' entries. -See `guix-ui-buffer-name' for details." - buffer-type-str entry-type-str) - (guix-ui-buffer-name ,buffer-name-val profile)) - - (defun ,get-fun (profile search-type &rest search-values) - ,(format "\ -Receive '%s' entries for displaying them in '%s' buffer. -See `guix-ui-get-entries' for details." - entry-type-str buffer-type-str) - (guix-ui-get-entries - profile ',entry-type search-type search-values - (cl-union ,required-var - (,displayed-fun ',entry-type)))) - - (defun ,message-fun (entries profile search-type - &rest search-values) - ,(format "\ -Display a message after showing '%s' entries." - entry-type-str) - (guix-result-message - profile entries ',entry-type search-type search-values)) - - (,definer ,entry-type - :get-entries-function ',get-fun - :message-function ',message-fun - :buffer-name ',buffer-name-fun - ,@%foreign-args))))) - -(defmacro guix-ui-info-define-interface (entry-type &rest args) - "Define 'info' interface for displaying ENTRY-TYPE entries. -See `guix-ui-define-interface'." - (declare (indent 1)) - `(guix-ui-define-interface info ,entry-type - ,@args)) - -(defmacro guix-ui-list-define-interface (entry-type &rest args) - "Define 'list' interface for displaying ENTRY-TYPE entries. -Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... - -Optional keywords: - - - `:describe-function' - default value of the generated - `guix-ENTRY-TYPE-list-describe-function' variable (if not - specified, use `guix-ui-list-describe'). - -The rest keyword arguments are passed to -`guix-ui-define-interface' macro." - (declare (indent 1)) - (guix-keyword-args-let args - ((describe-val :describe-function)) - `(guix-ui-define-interface list ,entry-type - :describe-function ,(or describe-val ''guix-ui-list-describe) - ,@args))) - - -(defvar guix-ui-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-ui-define-entry-type" - "guix-ui-define-interface" - "guix-ui-info-define-interface" - "guix-ui-list-define-interface")) - symbol-end) - . 1)))) - -(font-lock-add-keywords 'emacs-lisp-mode guix-ui-font-lock-keywords) - -(provide 'guix-ui) - -;;; guix-ui.el ends here diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el deleted file mode 100644 index 3e4ecc36ab..0000000000 --- a/emacs/guix-utils.el +++ /dev/null @@ -1,609 +0,0 @@ -;;; guix-utils.el --- General utility functions -*- lexical-binding: t -*- - -;; Copyright © 2014, 2015, 2016 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 auxiliary general functions for guix.el package. - -;;; Code: - -(require 'cl-lib) - -(defvar guix-true-string "Yes") -(defvar guix-false-string "–") -(defvar guix-list-separator ", ") - -(defvar guix-time-format "%F %T" - "String used to format time values. -For possible formats, see `format-time-string'.") - -(defun guix-get-string (val &optional face) - "Convert VAL into a string and return it. - -VAL can be an expression of any type. -If VAL is t/nil, it is replaced with -`guix-true-string'/`guix-false-string'. -If VAL is list, its elements are concatenated using -`guix-list-separator'. - -If FACE is non-nil, propertize returned string with this FACE." - (let ((str (cond - ((stringp val) val) - ((null val) guix-false-string) - ((eq t val) guix-true-string) - ((numberp val) (number-to-string val)) - ((listp val) (mapconcat #'guix-get-string - val guix-list-separator)) - (t (prin1-to-string val))))) - (if (and val face) - (propertize str 'font-lock-face face) - str))) - -(defun guix-get-time-string (seconds) - "Return formatted time string from SECONDS. -Use `guix-time-format'." - (format-time-string guix-time-format (seconds-to-time seconds))) - -(defun guix-get-one-line (str) - "Return one-line string from a multi-line STR." - (replace-regexp-in-string "\n" " " str)) - -(defmacro guix-with-indent (indent &rest body) - "Evaluate BODY and indent inserted text by INDENT number of spaces." - (declare (indent 1) (debug t)) - (let ((region-beg-var (make-symbol "region-beg")) - (indent-var (make-symbol "indent"))) - `(let ((,region-beg-var (point)) - (,indent-var ,indent)) - ,@body - (unless (zerop ,indent-var) - (indent-rigidly ,region-beg-var (point) ,indent-var))))) - -(defun guix-format-insert (val &optional face format) - "Convert VAL into a string and insert it at point. -If FACE is non-nil, propertize VAL with FACE. -If FORMAT is non-nil, format VAL with FORMAT." - (let ((str (guix-get-string val face))) - (insert (if format - (format format str) - str)))) - -(cl-defun guix-mapinsert (function sequence separator &key indent column) - "Like `mapconcat' but for inserting text. -Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR -at point between each FUNCTION call. - -If INDENT is non-nil, it should be a number of spaces used to -indent each line of the inserted text. - -If COLUMN is non-nil, it should be a column number which -shouldn't be exceeded by the inserted text." - (pcase sequence - (`(,first . ,rest) - (let* ((indent (or indent 0)) - (max-column (and column (- column indent)))) - (guix-with-indent indent - (funcall function first) - (dolist (element rest) - (let ((before-sep-pos (and column (point)))) - (insert separator) - (let ((after-sep-pos (and column (point)))) - (funcall function element) - (when (and column - (> (current-column) max-column)) - (save-excursion - (delete-region before-sep-pos after-sep-pos) - (goto-char before-sep-pos) - (insert "\n"))))))))))) - -(defun guix-insert-button (label &optional type &rest properties) - "Make button of TYPE with LABEL and insert it at point. -See `insert-text-button' for the meaning of PROPERTIES." - (if (null label) - (guix-format-insert nil) - (apply #'insert-text-button label - :type (or type 'button) - properties))) - -(defun guix-buttonize (value button-type separator &rest properties) - "Make BUTTON-TYPE button(s) from VALUE. -Return a string with button(s). - -VALUE should be a string or a list of strings. If it is a list -of strings, buttons are separated with SEPARATOR string. - -PROPERTIES are passed to `guix-insert-button'." - (with-temp-buffer - (let ((labels (if (listp value) value (list value)))) - (guix-mapinsert (lambda (label) - (apply #'guix-insert-button - label button-type properties)) - labels - separator)) - (buffer-substring (point-min) (point-max)))) - -(defun guix-button-type? (symbol) - "Return non-nil, if SYMBOL is a button type." - (and symbol - (get symbol 'button-category-symbol))) - -(defun guix-split-insert (val &optional face col separator) - "Convert VAL into a string, split it and insert at point. - -If FACE is non-nil, propertize returned string with this FACE. - -If COL is non-nil and result string is a one-line string longer -than COL, split it into several short lines. - -Separate inserted lines with SEPARATOR." - (if (null val) - (guix-format-insert nil) - (let ((strings (guix-split-string (guix-get-string val) col))) - (guix-mapinsert (lambda (str) (guix-format-insert str face)) - strings - (or separator ""))))) - -(defun guix-split-string (str &optional col) - "Split string STR by lines and return list of result strings. -If COL is non-nil, fill STR to this column." - (let ((str (if col - (guix-get-filled-string str col) - str))) - (split-string str "\n *" t))) - -(defun guix-get-filled-string (str col) - "Return string by filling STR to column COL." - (with-temp-buffer - (insert str) - (let ((fill-column col)) - (fill-region (point-min) (point-max))) - (buffer-string))) - -(defun guix-concat-strings (strings separator &optional location) - "Return new string by concatenating STRINGS with SEPARATOR. -If LOCATION is a symbol `head', add another SEPARATOR to the -beginning of the returned string; if `tail' - add SEPARATOR to -the end of the string; if nil, do not add SEPARATOR; otherwise -add both to the end and to the beginning." - (let ((str (mapconcat #'identity strings separator))) - (cond ((null location) - str) - ((eq location 'head) - (concat separator str)) - ((eq location 'tail) - (concat str separator)) - (t - (concat separator str separator))))) - -(defun guix-hexify (value) - "Convert VALUE to string and hexify it." - (url-hexify-string (guix-get-string value))) - -(defun guix-number->bool (number) - "Convert NUMBER to boolean value. -Return nil, if NUMBER is 0; return t otherwise." - (not (zerop number))) - -(defun guix-shell-quote-argument (argument) - "Quote shell command ARGUMENT. -This function is similar to `shell-quote-argument', but less strict." - (if (equal argument "") - "''" - (replace-regexp-in-string - "\n" "'\n'" - (replace-regexp-in-string - (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument)))) - -(defun guix-symbol-title (symbol) - "Return SYMBOL's name, a string. -This is like `symbol-name', but fancier." - (if (eq symbol 'id) - "ID" - (let ((str (replace-regexp-in-string "-" " " (symbol-name symbol)))) - (concat (capitalize (substring str 0 1)) - (substring str 1))))) - -(defun guix-command-symbol (&optional args) - "Return symbol by concatenating 'guix' and ARGS (strings)." - (intern (guix-concat-strings (cons "guix" args) "-"))) - -(defun guix-command-string (&optional args) - "Return 'guix ARGS ...' string with quoted shell arguments." - (let ((args (mapcar #'guix-shell-quote-argument args))) - (guix-concat-strings (cons "guix" args) " "))) - -(defun guix-copy-as-kill (string &optional no-message?) - "Put STRING into `kill-ring'. -If NO-MESSAGE? is non-nil, do not display a message about it." - (kill-new string) - (unless no-message? - (message "'%s' has been added to kill ring." string))) - -(defun guix-copy-command-as-kill (args &optional no-message?) - "Put 'guix ARGS ...' string into `kill-ring'. -See also `guix-copy-as-kill'." - (guix-copy-as-kill (guix-command-string args) no-message?)) - -(defun guix-compose-buffer-name (base-name postfix) - "Return buffer name by appending BASE-NAME and POSTFIX. - -In a simple case the result is: - - BASE-NAME: POSTFIX - -If BASE-NAME is wrapped by '*', then the result is: - - *BASE-NAME: POSTFIX*" - (let ((re (rx string-start - (group (? "*")) - (group (*? any)) - (group (? "*")) - string-end))) - (or (string-match re base-name) - (error "Unexpected error in defining buffer name")) - (let ((first* (match-string 1 base-name)) - (name-body (match-string 2 base-name)) - (last* (match-string 3 base-name))) - ;; Handle the case when buffer name is wrapped by '*'. - (if (and (string= "*" first*) - (string= "*" last*)) - (concat "*" name-body ": " postfix "*") - (concat base-name ": " postfix))))) - -(defun guix-completing-read (prompt table &optional predicate - require-match initial-input - hist def inherit-input-method) - "Same as `completing-read' but return nil instead of an empty string." - (let ((res (completing-read prompt table predicate - require-match initial-input - hist def inherit-input-method))) - (unless (string= "" res) res))) - -(defun guix-completing-read-multiple (prompt table &optional predicate - require-match initial-input - hist def inherit-input-method) - "Same as `completing-read-multiple' but remove duplicates in result." - (cl-remove-duplicates - (completing-read-multiple prompt table predicate - require-match initial-input - hist def inherit-input-method) - :test #'string=)) - -(declare-function org-read-date "org" t) - -(defun guix-read-date (prompt) - "Prompt for a date or time using `org-read-date'. -Return time value." - (require 'org) - (org-read-date nil t nil prompt)) - -(defun guix-read-file-name (prompt &optional dir default-filename - mustmatch initial predicate) - "Read file name. -This function is similar to `read-file-name' except it also -expands the file name." - (expand-file-name (read-file-name prompt dir default-filename - mustmatch initial predicate))) - -(defcustom guix-find-file-function #'find-file - "Function used to find a file. -The function is called by `guix-find-file' with a file name as a -single argument." - :type '(choice (function-item find-file) - (function-item org-open-file) - (function :tag "Other function")) - :group 'guix) - -(defun guix-find-file (file) - "Find FILE if it exists." - (if (file-exists-p file) - (funcall guix-find-file-function file) - (message "File '%s' does not exist." file))) - -(defvar url-handler-regexp) - -(defun guix-find-file-or-url (file-or-url) - "Find FILE-OR-URL." - (require 'url-handlers) - (let ((file-name-handler-alist - (cons (cons url-handler-regexp 'url-file-handler) - file-name-handler-alist))) - (find-file file-or-url))) - -(defmacro guix-while-search (regexp &rest body) - "Evaluate BODY after each search for REGEXP in the current buffer." - (declare (indent 1) (debug t)) - `(save-excursion - (goto-char (point-min)) - (while (re-search-forward ,regexp nil t) - ,@body))) - -(defmacro guix-while-null (&rest body) - "Evaluate BODY until its result becomes non-nil." - (declare (indent 0) (debug t)) - (let ((result-var (make-symbol "result"))) - `(let (,result-var) - (while (null ,result-var) - (setq ,result-var ,@body)) - ,result-var))) - -(defun guix-modify (object modifiers) - "Apply MODIFIERS to OBJECT. -OBJECT is passed as an argument to the first function from -MODIFIERS list, the returned result is passed to the second -function from the list and so on. Return result of the last -modifier call." - (if (null modifiers) - object - (guix-modify (funcall (car modifiers) object) - (cdr modifiers)))) - -(defmacro guix-keyword-args-let (args varlist &rest body) - "Parse ARGS, bind variables from VARLIST and eval BODY. - -Find keyword values in ARGS, bind them to variables according to -VARLIST, then evaluate BODY. - -ARGS is a keyword/value property list. - -Each element of VARLIST has a form: - - (SYMBOL KEYWORD [DEFAULT-VALUE]) - -SYMBOL is a varible name. KEYWORD is a symbol that will be -searched in ARGS for an according value. If the value of KEYWORD -does not exist, bind SYMBOL to DEFAULT-VALUE or nil. - -The rest arguments (that present in ARGS but not in VARLIST) will -be bound to `%foreign-args' variable. - -Example: - - (guix-keyword-args-let '(:two 8 :great ! :guix is) - ((one :one 1) - (two :two 2) - (foo :smth)) - (list one two foo %foreign-args)) - - => (1 8 nil (:guix is :great !))" - (declare (indent 2)) - (let ((args-var (make-symbol "args"))) - `(let (,@(mapcar (lambda (spec) - (pcase-let ((`(,name ,_ ,val) spec)) - (list name val))) - varlist) - (,args-var ,args) - %foreign-args) - (while ,args-var - (pcase ,args-var - (`(,key ,val . ,rest-args) - (cl-case key - ,@(mapcar (lambda (spec) - (pcase-let ((`(,name ,key ,_) spec)) - `(,key (setq ,name val)))) - varlist) - (t (setq %foreign-args - (cl-list* key val %foreign-args)))) - (setq ,args-var rest-args)))) - ,@body))) - - -;;; Alist procedures - -(defmacro guix-define-alist-accessor (name assoc-fun) - "Define NAME function to access alist values using ASSOC-FUN." - `(defun ,name (alist &rest keys) - ,(format "Return value from ALIST by KEYS using `%s'. -ALIST is alist of alists of alists ... which can be consecutively -accessed with KEYS." - assoc-fun) - (if (or (null alist) (null keys)) - alist - (apply #',name - (cdr (,assoc-fun (car keys) alist)) - (cdr keys))))) - -(guix-define-alist-accessor guix-assq-value assq) -(guix-define-alist-accessor guix-assoc-value assoc) - -(defun guix-alist-put (value alist &rest keys) - "Put (add or replace if exists) VALUE to ALIST using KEYS. -Return the new alist. - -ALIST is alist of alists of alists ... which can be consecutively -accessed with KEYS. - -Example: - - (guix-alist-put - 'foo - '((one (a . 1) (b . 2)) - (two (m . 7) (n . 8))) - 'one 'b) - - => ((one (a . 1) (b . foo)) - (two (m . 7) (n . 8)))" - (or keys (error "Keys should be specified")) - (guix-alist-put-1 value alist keys)) - -(defun guix-alist-put-1 (value alist keys) - "Subroutine of `guix-alist-put'." - (cond - ((null keys) - value) - ((null alist) - (list (cons (car keys) - (guix-alist-put-1 value nil (cdr keys))))) - ((eq (car keys) (caar alist)) - (cons (cons (car keys) - (guix-alist-put-1 value (cdar alist) (cdr keys))) - (cdr alist))) - (t - (cons (car alist) - (guix-alist-put-1 value (cdr alist) keys))))) - -(defun guix-alist-put! (value variable &rest keys) - "Modify alist VARIABLE (symbol) by putting VALUE using KEYS. -See `guix-alist-put' for details." - (set variable - (apply #'guix-alist-put value (symbol-value variable) keys))) - - -;;; Diff - -(defvar guix-diff-switches "-u" - "A string or list of strings specifying switches to be passed to diff.") - -(defun guix-diff (old new &optional switches no-async) - "Same as `diff', but use `guix-diff-switches' as default." - (diff old new (or switches guix-diff-switches) no-async)) - - -;;; Completing readers definers - -(defmacro guix-define-reader (name read-fun completions prompt) - "Define NAME function to read from minibuffer. -READ-FUN may be `completing-read', `completing-read-multiple' or -another function with the same arguments." - `(defun ,name (&optional prompt initial-contents) - (,read-fun ,(if prompt - `(or prompt ,prompt) - 'prompt) - ,completions nil nil initial-contents))) - -(defmacro guix-define-readers (&rest args) - "Define reader functions. - -ARGS should have a form [KEYWORD VALUE] ... The following -keywords are available: - - - `completions-var' - variable used to get completions. - - - `completions-getter' - function used to get completions. - - - `single-reader', `single-prompt' - name of a function to read - a single value, and a prompt for it. - - - `multiple-reader', `multiple-prompt' - name of a function to - read multiple values, and a prompt for it. - - - `multiple-separator' - if specified, another - `<multiple-reader-name>-string' function returning a string - of multiple values separated the specified separator will be - defined." - (guix-keyword-args-let args - ((completions-var :completions-var) - (completions-getter :completions-getter) - (single-reader :single-reader) - (single-prompt :single-prompt) - (multiple-reader :multiple-reader) - (multiple-prompt :multiple-prompt) - (multiple-separator :multiple-separator)) - (let ((completions - (cond ((and completions-var completions-getter) - `(or ,completions-var - (setq ,completions-var - (funcall ',completions-getter)))) - (completions-var - completions-var) - (completions-getter - `(funcall ',completions-getter))))) - `(progn - ,(when (and completions-var - (not (boundp completions-var))) - `(defvar ,completions-var nil)) - - ,(when single-reader - `(guix-define-reader ,single-reader guix-completing-read - ,completions ,single-prompt)) - - ,(when multiple-reader - `(guix-define-reader ,multiple-reader completing-read-multiple - ,completions ,multiple-prompt)) - - ,(when (and multiple-reader multiple-separator) - (let ((name (intern (concat (symbol-name multiple-reader) - "-string")))) - `(defun ,name (&optional prompt initial-contents) - (guix-concat-strings - (,multiple-reader prompt initial-contents) - ,multiple-separator)))))))) - - -;;; Memoizing - -(defun guix-memoize (function) - "Return a memoized version of FUNCTION." - (let ((cache (make-hash-table :test 'equal))) - (lambda (&rest args) - (let ((result (gethash args cache 'not-found))) - (if (eq result 'not-found) - (let ((result (apply function args))) - (puthash args result cache) - result) - result))))) - -(defmacro guix-memoized-defun (name arglist docstring &rest body) - "Define a memoized function NAME. -See `defun' for the meaning of arguments." - (declare (doc-string 3) (indent 2)) - `(defalias ',name - (guix-memoize (lambda ,arglist ,@body)) - ;; Add '(name args ...)' string with real arglist to the docstring, - ;; because *Help* will display '(name &rest ARGS)' for a defined - ;; function (since `guix-memoize' returns a lambda with '(&rest - ;; args)'). - ,(format "(%S %s)\n\n%s" - name - (mapconcat #'symbol-name arglist " ") - docstring))) - -(defmacro guix-memoized-defalias (symbol definition &optional docstring) - "Set SYMBOL's function definition to memoized version of DEFINITION." - (declare (doc-string 3) (indent 1)) - `(defalias ',symbol - (guix-memoize #',definition) - ,(or docstring - (format "Memoized version of `%S'." definition)))) - - -(defvar guix-utils-font-lock-keywords - (eval-when-compile - `((,(rx "(" (group (or "guix-define-reader" - "guix-define-readers" - "guix-keyword-args-let" - "guix-while-null" - "guix-while-search" - "guix-with-indent")) - symbol-end) - . 1) - (,(rx "(" - (group "guix-memoized-" (or "defun" "defalias")) - 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-utils-font-lock-keywords) - -(provide 'guix-utils) - -;;; guix-utils.el ends here diff --git a/emacs/local.mk b/emacs/local.mk deleted file mode 100644 index 959ec2dd34..0000000000 --- a/emacs/local.mk +++ /dev/null @@ -1,77 +0,0 @@ -# GNU Guix --- Functional package management for GNU -# Copyright © 2014, 2015, 2016 Alex Kost <alezost@gmail.com> -# Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> -# -# 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -AUTOLOADS = %D%/guix-autoloads.el - -ELFILES = \ - %D%/guix-about.el \ - %D%/guix-backend.el \ - %D%/guix-base.el \ - %D%/guix-build-log.el \ - %D%/guix-buffer.el \ - %D%/guix-command.el \ - %D%/guix-devel.el \ - %D%/guix-emacs.el \ - %D%/guix-entry.el \ - %D%/guix-external.el \ - %D%/guix-geiser.el \ - %D%/guix-guile.el \ - %D%/guix-help-vars.el \ - %D%/guix-history.el \ - %D%/guix-hydra.el \ - %D%/guix-hydra-build.el \ - %D%/guix-hydra-jobset.el \ - %D%/guix-info.el \ - %D%/guix-init.el \ - %D%/guix-license.el \ - %D%/guix-list.el \ - %D%/guix-location.el \ - %D%/guix-messages.el \ - %D%/guix-pcomplete.el \ - %D%/guix-popup.el \ - %D%/guix-prettify.el \ - %D%/guix-profiles.el \ - %D%/guix-read.el \ - %D%/guix-ui.el \ - %D%/guix-ui-license.el \ - %D%/guix-ui-location.el \ - %D%/guix-ui-package.el \ - %D%/guix-ui-generation.el \ - %D%/guix-ui-system-generation.el \ - %D%/guix-utils.el - -if HAVE_EMACS - -dist_lisp_DATA = $(ELFILES) - -nodist_lisp_DATA = \ - %D%/guix-config.el \ - $(AUTOLOADS) - -$(AUTOLOADS): $(ELFILES) - $(AM_V_EMACS)$(EMACS) --batch --eval \ - "(let ((backup-inhibited t) \ - (generated-autoload-file \ - (expand-file-name \"$(AUTOLOADS)\" \"$(builddir)\"))) \ - (update-directory-autoloads \ - (expand-file-name \"emacs\" \"$(srcdir)\")))" - -CLEANFILES += $(AUTOLOADS) - -endif HAVE_EMACS |