diff options
| author | Alex Kost <alezost@gmail.com> | 2014-08-27 16:44:17 +0400 |
|---|---|---|
| committer | Alex Kost <alezost@gmail.com> | 2014-09-03 23:50:35 +0400 |
| commit | 457f60fa068c7becf60841daa2b6fc5121aedead (patch) | |
| tree | 8cae5e141a6c5c643255b6777e19c063010cf6f0 /emacs | |
| parent | a423555d3c4314f8347d75b050d7daf6e594281f (diff) | |
| download | guix-457f60fa068c7becf60841daa2b6fc5121aedead.tar.gz | |
Add Emacs user interface.
* configure.ac (emacsuidir): New variable. (AC_CONFIG_FILES): Add 'emacs/guix-init.el', 'emacs/guix-helper.scm'. * Makefile.am: Include 'emacs.am'. * emacs.am: New file. * doc/emacs.texi: New file. * doc/guix.texi: Include 'emacs.texi'. * emacs/guix-backend.el: New file. * emacs/guix-base.el: New file. * emacs/guix-helper.scm.in: New file. * emacs/guix-history.el: New file. * emacs/guix-info.el: New file. * emacs/guix-init.el.in: New file. * emacs/guix-list.el: New file. * emacs/guix-main.scm: New file. * emacs/guix-utils.el: New file. * emacs/guix.el: New file.
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/guix-backend.el | 301 | ||||
| -rw-r--r-- | emacs/guix-base.el | 607 | ||||
| -rw-r--r-- | emacs/guix-helper.scm.in | 64 | ||||
| -rw-r--r-- | emacs/guix-history.el | 92 | ||||
| -rw-r--r-- | emacs/guix-info.el | 556 | ||||
| -rw-r--r-- | emacs/guix-init.el.in | 14 | ||||
| -rw-r--r-- | emacs/guix-list.el | 586 | ||||
| -rw-r--r-- | emacs/guix-main.scm | 603 | ||||
| -rw-r--r-- | emacs/guix-utils.el | 160 | ||||
| -rw-r--r-- | emacs/guix.el | 141 |
10 files changed, 3124 insertions, 0 deletions
diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el new file mode 100644 index 0000000000..46d0f06778 --- /dev/null +++ b/emacs/guix-backend.el @@ -0,0 +1,301 @@ +;;; guix-backend.el --- Communication with Geiser + +;; 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 the code for interacting with Guile using Geiser. + +;; By default (if `guix-use-guile-server' is non-nil) 2 Geiser 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>). +;; +;; If you need to use "guix.el" in another Emacs (i.e. when there is +;; a runnig "guile --listen..." REPL somewhere), you can either change +;; `guix-default-port' in that Emacs instance or set +;; `guix-use-guile-server' to t. +;; +;; 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 "M-x +;; connect-to-guile" (connect to "localhost" and `guix-default-port') to +;; have a usual Geiser REPL with all stuff defined by "guix.el" package. + +;;; Code: + +(require 'geiser-mode) + +(defvar guix-load-path + (file-name-directory (or load-file-name + (locate-library "guix"))) + "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.") + +(defvar guix-guile-program (or geiser-guile-binary "guile") + "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.") + + +;;; 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 () + "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-default-port 37246 + "Default port used if `guix-use-guile-server' is non-nil." + :type 'integer + :group '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.") + +(defun guix-get-guile-program (&optional internal) + "Return a value suitable for `geiser-guile-binary'." + (if (or internal + (not guix-use-guile-server)) + guix-guile-program + (append (if (listp guix-guile-program) + guix-guile-program + (list guix-guile-program)) + ;; Guile understands "--listen=..." but not "--listen ..." + (list (concat "--listen=" + (number-to-string guix-default-port)))))) + +(defun guix-start-process-maybe () + "Start Geiser REPL configured for Guix if needed." + (guix-start-repl-maybe) + (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 Guix REPL if needed. +If INTERNAL is non-nil, start an internal REPL." + (let* ((repl-var (guix-get-repl-buffer-variable internal)) + (repl (symbol-value repl-var))) + (unless (and (buffer-live-p repl) + (get-buffer-process repl)) + ;; Kill REPL buffer with a dead process + (and (buffer-live-p repl) (kill-buffer repl)) + (or internal + (message "Starting Geiser REPL for Guix ...")) + (let ((geiser-guile-binary (guix-get-guile-program internal)) + (geiser-guile-init-file (or internal guix-helper-file)) + (repl (get-buffer-create + (guix-get-repl-buffer-name internal)))) + (condition-case err + (guix-start-repl repl + (and internal + (geiser-repl--read-address + "localhost" guix-default-port))) + (text-read-only + (error (concat "Couldn't start Guix REPL. Perhaps the port %s is busy.\n" + "See buffer '%s' for details") + guix-default-port (buffer-name repl)))) + (set repl-var repl) + (unless internal + (message "Guix REPL has been started.") + (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 (list guix-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-re (geiser-repl--prompt-regexp impl)) + (deb-prompt-re (geiser-repl--debugger-prompt-regexp impl)) + (prompt (geiser-con--combined-prompt prompt-re deb-prompt-re))) + (or prompt-re + (error "Oh no! Guix REPL in the buffer '%s' has not been started" + (buffer-name buffer))) + (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)) + prompt-re + deb-prompt-re)) + (geiser-repl--startup impl address) + (geiser-repl--autodoc-mode 1) + (geiser-company--setup geiser-repl-company-p) + (add-hook 'comint-output-filter-functions + 'geiser-repl--output-filter + nil t) + (set-process-query-on-exit-flag + (get-buffer-process (current-buffer)) + geiser-repl-query-on-kill-p))))) + +(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))) + + +;;; Evaluating expressions + +(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-eval (str &optional wrap) + "Evaluate guile expression STR. +If WRAP is non-nil, wrap STR into (begin ...) form. +Return a list of strings with result values of evaluation." + (with-current-buffer (guix-get-repl-buffer 'internal) + (let* ((wrapped (if wrap (geiser-debug--wrap-region str) str)) + (code `(:eval (:scm ,wrapped))) + (ret (geiser-eval--send/wait code))) + (if (geiser-eval--retort-error ret) + (error "Error in evaluating guile expression: %s" + (geiser-eval--retort-output ret)) + (cdr (assq 'result ret)))))) + +(defun guix-eval-read (str &optional wrap) + "Evaluate guile expression STR. +For the meaning of WRAP, see `guix-eval'. +Return elisp expression of the first result value of evaluation." + ;; Parsing scheme code with elisp `read' is probably not the best idea. + (read (replace-regexp-in-string + "#f\\|#<unspecified>" "nil" + (replace-regexp-in-string + "#t" "t" (car (guix-eval str wrap)))))) + +(defun guix-eval-in-repl (str) + "Switch to Guix REPL and evaluate STR with guile expression there." + (let ((repl (guix-get-repl-buffer))) + (with-current-buffer repl + (delete-region (geiser-repl--last-prompt-end) (point-max)) + (goto-char (point-max)) + (insert str) + (geiser-repl--send-input)) + (geiser-repl--switch-to-buffer repl))) + +(provide 'guix-backend) + +;;; guix-backend.el ends here diff --git a/emacs/guix-base.el b/emacs/guix-base.el new file mode 100644 index 0000000000..563df496cd --- /dev/null +++ b/emacs/guix-base.el @@ -0,0 +1,607 @@ +;;; guix-base.el --- Common definitions + +;; 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 some base and common definitions for guix.el +;; package. + +;; List and info buffers have many common patterns that are defined +;; using `guix-define-buffer-type' macro from this file. + +;;; Code: + +(require 'cl-lib) +(require 'guix-backend) +(require 'guix-utils) + + +;;; Profiles + +(defvar guix-user-profile + (expand-file-name "~/.guix-profile") + "User profile.") + +(defvar guix-default-profile + (concat (or (getenv "NIX_STATE_DIR") "/var/guix") + "/profiles/per-user/" + (getenv "USER") + "/guix-profile") + "Default Guix profile.") + +(defvar guix-current-profile guix-default-profile + "Current profile.") + +(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 + (read-file-name "Set profile: " + (file-name-directory guix-current-profile))))) + (let ((path (directory-file-name (expand-file-name path)))) + (setq guix-current-profile + (if (string= path guix-user-profile) + guix-default-profile + path)) + (message "Current profile has been set to '%s'." + guix-current-profile))) + + +;;; Parameters of the entries + +(defvar guix-param-titles + '((package + (id . "ID") + (name . "Name") + (version . "Version") + (license . "License") + (synopsis . "Synopsis") + (description . "Description") + (home-url . "Home page") + (outputs . "Outputs") + (inputs . "Inputs") + (native-inputs . "Native inputs") + (propagated-inputs . "Propagated inputs") + (location . "Location") + (installed . "Installed")) + (installed + (path . "Installed path") + (dependencies . "Dependencies") + (output . "Output")) + (generation + (id . "ID") + (number . "Number") + (prev-number . "Previous number") + (path . "Path") + (time . "Time"))) + "List for defining titles of entry parameters. +Titles are used for displaying information about entries. +Each element of the list has a form: + + (ENTRY-TYPE . ((PARAM . TITLE) ...))") + +(defun guix-get-param-title (entry-type param) + "Return title of an ENTRY-TYPE entry parameter PARAM." + (or (guix-get-key-val guix-param-titles + entry-type param) + (prog1 (symbol-name param) + (message "Couldn't find title for '%S %S'." + entry-type param)))) + +(defun guix-get-name-spec (name version &optional output) + "Return Guix package specification by its NAME, VERSION and OUTPUT." + (concat name "-" version + (when output (concat ":" output)))) + +(defun guix-get-full-name (entry &optional output) + "Return name specification of the package ENTRY and OUTPUT." + (guix-get-name-spec (guix-get-key-val entry 'name) + (guix-get-key-val entry 'version) + output)) + +(defun guix-get-installed-outputs (entry) + "Return list of installed outputs for the package ENTRY." + (mapcar (lambda (installed-entry) + (guix-get-key-val installed-entry 'output)) + (guix-get-key-val entry 'installed))) + +(defun guix-get-entry-by-id (id entries) + "Return entry from ENTRIES by entry ID." + (cl-find-if (lambda (entry) + (equal id (guix-get-key-val entry 'id))) + entries)) + + +;;; Location of the packages + +(defvar guix-directory nil + "Default Guix directory. +If it is not set by a user, it is set after starting Guile REPL. +This directory is used to define location of the packages.") + +(defun guix-set-directory () + "Set `guix-directory' if needed." + (or guix-directory + (setq guix-directory + (guix-eval-read "%guix-dir")))) + +(add-hook 'guix-after-start-repl-hook 'guix-set-directory) + +(defun guix-find-location (location) + "Go to LOCATION of a package. +LOCATION is a string of the form: + + \"PATH:LINE:COLUMN\" + +If PATH is relative, it is considered to be relative to +`guix-directory'." + (cl-multiple-value-bind (path line col) + (split-string location ":") + (let ((file (expand-file-name path guix-directory)) + (line (string-to-number line)) + (col (string-to-number col))) + (find-file file) + (goto-char (point-min)) + (forward-line (- line 1)) + (move-to-column col) + (recenter 1)))) + + +;;; Common definitions for buffer types + +(defvar-local guix-entries nil + "List of the currently displayed entries. +Each element of the list is alist with entry info of the +following form: + + ((PARAM . VAL) ...) + +PARAM is a name of the entry parameter. +VAL is a value of this parameter.") +(put 'guix-entries 'permanent-local t) + +(defvar-local guix-search-type nil + "Type of the current search.") +(put 'guix-search-type 'permanent-local t) + +(defvar-local guix-search-vals nil + "Values of the current search.") +(put 'guix-search-vals 'permanent-local t) + +(defsubst guix-set-vars (entries search-type search-vals) + (setq guix-entries entries + guix-search-type search-type + guix-search-vals search-vals)) + +(defmacro guix-define-buffer-type (buf-type entry-type &rest args) + "Define common stuff for BUF-TYPE buffers for displaying entries. + +ENTRY-TYPE is a type of displayed entries (see +`guix-get-entries'). + +In the text below TYPE means ENTRY-TYPE-BUF-TYPE. + +This macro defines `guix-TYPE-mode', a custom group, several user +variables and the following functions: + + - `guix-TYPE-get-params-for-receiving' + - `guix-TYPE-revert' + - `guix-TYPE-redisplay' + - `guix-TYPE-make-history-item' + - `guix-TYPE-set' + - `guix-TYPE-show' + - `guix-TYPE-get-show' + +The following stuff should be defined outside this macro: + + - `guix-BUF-TYPE-mode' - parent mode for the defined mode. + + - `guix-BUF-TYPE-insert-entries' - function for inserting + entries in the current buffer; it is called with 2 arguments: + entries of the form of `guix-entries' and ENTRY-TYPE. + + - `guix-BUF-TYPE-get-displayed-params' - function returning a + list of parameters displayed in the current buffer; it is + called with ENTRY-TYPE as argument. + + - `guix-TYPE-mode-initialize' (optional) - function for + additional mode settings; it is called without arguments. + +Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The +following keywords are available: + + - `:required' - default value for the defined + `guix-TYPE-required-params' variable. + + - `:history-size' - default value for the defined + `guix-TYPE-history-size' variable. + + - `:revert' - default value for the defined + `guix-TYPE-revert-no-confirm' variable." + (let* ((entry-type-str (symbol-name entry-type)) + (buf-type-str (symbol-name buf-type)) + (Entry-type-str (capitalize entry-type-str)) + (Buf-type-str (capitalize buf-type-str)) + (entry-str (concat entry-type-str " entries")) + (buf-str (concat buf-type-str " buffer")) + (prefix (concat "guix-" entry-type-str "-" buf-type-str)) + (group (intern prefix)) + (mode-map-str (concat prefix "-mode-map")) + (mode-map (intern mode-map-str)) + (parent-mode (intern (concat "guix-" buf-type-str "-mode"))) + (mode (intern (concat prefix "-mode"))) + (mode-init-fun (intern (concat prefix "-mode-initialize"))) + (buf-name-var (intern (concat prefix "-buffer-name"))) + (revert-var (intern (concat prefix "-revert-no-confirm"))) + (revert-fun (intern (concat prefix "-revert"))) + (redisplay-fun (intern (concat prefix "-redisplay"))) + (history-var (intern (concat prefix "-history-size"))) + (history-fun (intern (concat prefix "-make-history-item"))) + (params-var (intern (concat prefix "-required-params"))) + (params-fun (intern (concat prefix "-get-params-for-receiving"))) + (set-fun (intern (concat prefix "-set"))) + (show-fun (intern (concat prefix "-show"))) + (get-show-fun (intern (concat prefix "-get-show"))) + (revert-val nil) + (history-val 20) + (params-val '(id))) + + ;; Process the keyword args. + (while (keywordp (car args)) + (pcase (pop args) + (`:required (setq params-val (pop args))) + (`:history-size (setq history-val (pop args))) + (`:revert (setq revert-val (pop args))) + (_ (pop args)))) + + `(progn + (defgroup ,group nil + ,(concat Buf-type-str " buffer with " entry-str ".") + :prefix ,(concat prefix "-") + :group ',(intern (concat "guix-" buf-type-str))) + + (defcustom ,buf-name-var ,(format "*Guix %s %s*" + Entry-type-str Buf-type-str) + ,(concat "Default name of the " buf-str " for displaying " entry-str ".") + :type 'string + :group ',group) + + (defcustom ,history-var ,history-val + ,(concat "Maximum number of items saved in the history of the " buf-str ".\n" + "If 0, the history is disabled.") + :type 'integer + :group ',group) + + (defcustom ,revert-var ,revert-val + ,(concat "If non-nil, do not ask to confirm for reverting the " buf-str ".") + :type 'boolean + :group ',group) + + (defvar ,params-var ',params-val + ,(concat "List of required " entry-type-str " parameters.\n\n" + "Displayed parameters and parameters from this list are received\n" + "for each " entry-type-str ".\n\n" + "May be a special value `all', in which case all supported\n" + "parameters are received (this may be very slow for a big number\n" + "of entries).\n\n" + "Do not remove `id' from this list as it is required for\n" + "identifying an entry.")) + + (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str) + ,(concat "Major mode for displaying information about " entry-str ".\n\n" + "\\{" mode-map-str "}") + (setq-local revert-buffer-function ',revert-fun) + (setq-local guix-history-size ,history-var) + (and (fboundp ',mode-init-fun) (,mode-init-fun))) + + (let ((map ,mode-map)) + (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") ',redisplay-fun) + (define-key map (kbd "C-c C-z") 'guix-switch-to-repl)) + + (defun ,params-fun () + ,(concat "Return " entry-type-str " parameters that should be received.") + (unless (equal ,params-var 'all) + (cl-union ,params-var + (,(intern (concat "guix-" buf-type-str "-get-displayed-params")) + ',entry-type)))) + + (defun ,revert-fun (_ignore-auto noconfirm) + "Update information in the current buffer. +The function is suitable for `revert-buffer-function'. +See `revert-buffer' for the meaning of NOCONFIRM." + (when (or ,revert-var + noconfirm + (y-or-n-p "Update current information? ")) + (let ((entries (guix-get-entries ',entry-type guix-search-type + guix-search-vals (,params-fun)))) + (,set-fun entries guix-search-type guix-search-vals t)))) + + (defun ,redisplay-fun () + "Redisplay current information. +This function will not update the information, use +\"\\[revert-buffer]\" if you want the full update." + (interactive) + (,show-fun guix-entries) + (guix-result-message guix-entries ',entry-type + guix-search-type guix-search-vals)) + + (defun ,history-fun () + "Make and return a history item for the current buffer." + (list (lambda (entries search-type search-vals) + (,show-fun entries) + (guix-set-vars entries search-type search-vals) + (guix-result-message entries ',entry-type + search-type search-vals)) + guix-entries guix-search-type guix-search-vals)) + + (defun ,set-fun (entries search-type search-vals &optional history-replace) + ,(concat "Set up the " buf-str " for displaying " entry-str ".\n\n" + "Display ENTRIES, set variables and make history item.\n\n" + "ENTRIES should have a form of `guix-entries'.\n\n" + "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" + "SEARCH-VALS.\n\n" + "If HISTORY-REPLACE is non-nil, replace current history item,\n" + "otherwise add the new one.") + (when entries + (let ((buf (if (eq major-mode ',mode) + (current-buffer) + (get-buffer-create ,buf-name-var)))) + (with-current-buffer buf + (,show-fun entries) + (guix-set-vars entries search-type search-vals) + (funcall (if history-replace + #'guix-history-replace + #'guix-history-add) + (,history-fun))) + (pop-to-buffer buf + '((display-buffer-reuse-window + display-buffer-same-window))))) + (guix-result-message entries ',entry-type + search-type search-vals)) + + (defun ,show-fun (entries) + ,(concat "Display " entry-type-str " ENTRIES in the current " buf-str ".") + (let ((inhibit-read-only t)) + (erase-buffer) + (,mode) + (,(intern (concat "guix-" buf-type-str "-insert-entries")) + entries ',entry-type) + (goto-char (point-min)))) + + (defun ,get-show-fun (search-type &rest search-vals) + ,(concat "Search for " entry-str " and show results in the " buf-str ".\n" + "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" + "SEARCH-VALS.") + (let ((entries (guix-get-entries ',entry-type search-type + search-vals (,params-fun)))) + (,set-fun entries search-type search-vals)))))) + +(put 'guix-define-buffer-type 'lisp-indent-function 'defun) + + +;;; Messages + +(defvar guix-messages + '((package + (id + (0 "Packages not found.") + (1 "") + (many "%d packages." count)) + (name + (0 "The package '%s' not found." val) + (1 "A single package with name '%s'." val) + (many "%d packages with '%s' name." count 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 installed packages.") + (1 "A single installed package.") + (many "%d installed packages." count)) + (obsolete + (0 "No obsolete packages.") + (1 "A single obsolete package.") + (many "%d obsolete packages." count)) + (generation + (0 "No packages installed in generation %d." val) + (1 "A single package installed in generation %d." val) + (many "%d packages installed in generation %d." count val))) + (generation + (id + (0 "Generations not found.") + (1 "") + (many "%d generations." count)) + (last + (0 "No available generations.") + (1 "The last generation.") + (many "%d last generations." count)) + (all + (0 "No available generations.") + (1 "A single available generation.") + (many "%d available generations." count))))) + +(defun guix-result-message (entries entry-type search-type search-vals) + "Display an appropriate message after displaying ENTRIES." + (let* ((val (car search-vals)) + (count (length entries)) + (count-key (if (> count 1) 'many count)) + (msg-spec (guix-get-key-val guix-messages + entry-type search-type count-key)) + (format (car msg-spec)) + (args (cdr msg-spec))) + (mapc (lambda (subst) + (setq args (cl-substitute (car subst) (cdr subst) args))) + (list (cons count 'count) + (cons val 'val))) + (apply #'message format args))) + + +;;; Getting info about packages and generations + +(defun guix-get-entries (entry-type search-type search-vals &optional params) + "Search for entries of ENTRY-TYPE. + +Call an appropriate scheme function and return a list of the +form of `guix-entries'. + +ENTRY-TYPE should be one of the following symbols: `package' or +`generation'. + +SEARCH-TYPE may be one of the following symbols: + +- If ENTRY-TYPE is `package': `id', `name', `regexp', + `all-available', `newest-available', `installed', `obsolete', + `generation'. + +- If ENTRY-TYPE is `generation': `id', `last', `all'. + +PARAMS is a list of parameters for receiving. If nil, get +information with all available parameters." + (guix-eval-read (guix-make-guile-expression + 'get-entries + guix-current-profile params + entry-type search-type search-vals))) + + +;;; Actions on packages and generations + +(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.") + +(defun guix-process-package-actions (&rest actions) + "Process package ACTIONS. +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 + :install install :upgrade upgrade :remove remove) + (guix-eval-in-repl + (guix-make-guile-expression + 'process-package-actions guix-current-profile + :install install :upgrade upgrade :remove remove + :use-substitutes? (or guix-use-substitutes 'f) + :dry-run? (or guix-dry-run 'f)))))) + +(cl-defun guix-continue-package-operation-p (&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-get-entries + 'package 'id + (list (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) + (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 (y-or-n-p "Continue operation? ") + (quit-window nil win))))) + (message "Nothing to be done. If the REPL was restarted, information 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-get-entry-by-id id entries))) + (when entry + (let ((location (guix-get-key-val entry 'location))) + (concat (guix-get-full-name entry) + (when outputs + (concat ":" + (mapconcat #'identity 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 " (guix-get-string action 'bold) ":\n") + (mapc (lambda (str) + (insert " " str "\n")) + strings) + (insert "\n"))) + +(provide 'guix-base) + +;;; guix-base.el ends here diff --git a/emacs/guix-helper.scm.in b/emacs/guix-helper.scm.in new file mode 100644 index 0000000000..554d55119f --- /dev/null +++ b/emacs/guix-helper.scm.in @@ -0,0 +1,64 @@ +;;; 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-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 new file mode 100644 index 0000000000..5d301a689e --- /dev/null +++ b/emacs/guix-history.el @@ -0,0 +1,92 @@ +;;; 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-info.el b/emacs/guix-info.el new file mode 100644 index 0000000000..687a15eefa --- /dev/null +++ b/emacs/guix-info.el @@ -0,0 +1,556 @@ +;;; guix-info.el --- Info buffers for displaying entries + +;; 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 a help-like buffer for displaying information +;; about Guix packages and generations. + +;;; Code: + +(require 'guix-history) +(require 'guix-base) +(require 'guix-utils) + +(defgroup guix-info nil + "General settings for info buffers." + :prefix "guix-info-" + :group 'guix) + +(defface guix-info-param-title + '((t :inherit font-lock-type-face)) + "Face used for titles of parameters." + :group 'guix-info) + +(defface guix-info-file-path + '((t :inherit link)) + "Face used for file paths." + :group 'guix-info) + +(defface guix-info-url + '((t :inherit link)) + "Face used for URLs." + :group 'guix-info) + +(defface guix-info-time + '((t :inherit font-lock-constant-face)) + "Face used for timestamps." + :group 'guix-info) + +(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) + +(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) + +(defcustom guix-info-ignore-empty-vals nil + "If non-nil, do not display parameters with nil values." + :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-default'.") + +(defvar guix-info-multiline-prefix (make-string 20 ?\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-val-default'.") + +(defvar guix-info-indent 2 + "Number of spaces used to indent various parts of inserted text.") + +(defvar guix-info-fill-column 60 + "Column used for filling (word wrapping) parameters with long lines. +If a value is not multi-line and it occupies more than this +number of characters, it will be split into several lines.") + +(defvar guix-info-delimiter "\n\f\n" + "String used to separate entries.") + +(defvar guix-info-insert-methods + '((package + (name guix-package-info-name) + (version guix-package-info-version) + (license guix-package-info-license) + (synopsis guix-package-info-synopsis) + (description guix-package-info-insert-description + guix-info-insert-title-simple) + (outputs guix-package-info-insert-outputs + guix-info-insert-title-simple) + (home-url guix-info-insert-url) + (inputs guix-package-info-insert-inputs) + (native-inputs guix-package-info-insert-native-inputs) + (propagated-inputs guix-package-info-insert-propagated-inputs) + (location guix-package-info-insert-location)) + (installed + (path guix-package-info-insert-output-path + guix-info-insert-title-simple) + (dependencies guix-package-info-insert-output-dependencies + guix-info-insert-title-simple)) + (generation + (number guix-generation-info-insert-number) + (path guix-info-insert-file-path) + (time guix-info-insert-time))) + "Methods for inserting parameter values. +Each element of the list should have a form: + + (ENTRY-TYPE . ((PARAM INSERT-VALUE [INSERT-TITLE]) ...)) + +INSERT-VALUE may be either nil, a face name or a function. If it +is nil or a face, `guix-info-insert-val-default' function is +called with parameter value and INSERT-VALUE as arguments. If it +is a function, this function is called with parameter value and +entry info (alist of parameters and their values) as arguments. + +INSERT-TITLE may be either nil, a face name or a function. If it +is nil or a face, `guix-info-insert-title-default' function is +called with parameter title and INSERT-TITLE as arguments. If it +is a function, this function is called with parameter title as +argument.") + +(defvar guix-info-displayed-params + '((package name version synopsis outputs location home-url + license inputs native-inputs propagated-inputs description) + (installed path dependencies) + (generation number prev-number time path)) + "List of displayed entry parameters. +Each element of the list should have a form: + + (ENTRY-TYPE . (PARAM ...)) + +The order of displayed parameters is the same as in this list.") + +(defun guix-info-get-insert-methods (entry-type param) + "Return list of insert methods for parameter PARAM of ENTRY-TYPE. +See `guix-info-insert-methods' for details." + (guix-get-key-val guix-info-insert-methods + entry-type param)) + +(defun guix-info-get-displayed-params (entry-type) + "Return parameters of ENTRY-TYPE that should be displayed." + (guix-get-key-val guix-info-displayed-params + entry-type)) + +(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 ENTRIES of ENTRY-TYPE in the current info buffer. +ENTRIES should have a form of `guix-entries'." + (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 information by this +number of `guix-info-indent' spaces." + (let ((region-beg (point))) + (mapc (lambda (param) + (guix-info-insert-param param entry entry-type)) + (guix-info-get-displayed-params entry-type)) + (when indent-level + (indent-rigidly region-beg (point) + (* indent-level guix-info-indent))))) + +(defun guix-info-insert-param (param 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." + (let ((val (guix-get-key-val entry param))) + (unless (and guix-info-ignore-empty-vals (null val)) + (let* ((title (guix-get-param-title entry-type param)) + (insert-methods (guix-info-get-insert-methods entry-type param)) + (val-method (car insert-methods)) + (title-method (cadr insert-methods))) + (guix-info-method-funcall title title-method + #'guix-info-insert-title-default) + (guix-info-method-funcall val val-method + #'guix-info-insert-val-default + entry) + (insert "\n"))))) + +(defun guix-info-method-funcall (val method default-fun &rest args) + "Call METHOD or DEFAULT-FUN. + +If METHOD is a function and VAL is non-nil, call this +function by applying it to VAL and ARGS. + +If METHOD is a face, propertize inserted VAL with this face." + (cond ((or (null method) + (facep method)) + (funcall default-fun val method)) + ((functionp method) + (apply method val args)) + (t (error "Unknown method '%S'" method)))) + +(defun guix-info-insert-title-default (title &optional face format) + "Insert TITLE formatted with `guix-info-param-title-format' at point." + (guix-format-insert title + (or face 'guix-info-param-title) + (or format guix-info-param-title-format))) + +(defun guix-info-insert-title-simple (title &optional face) + "Insert TITLE at point." + (guix-info-insert-title-default title face "%s:")) + +(defun guix-info-insert-val-default (val &optional face) + "Format and insert parameter value VAL at point. + +This function is intended to be called after +`guix-info-insert-title-default'. + +If VAL is a one-line string longer than `guix-info-fill-column', +split it into several short lines. See also +`guix-info-multiline-prefix'. + +If FACE is non-nil, propertize inserted line(s) with this FACE." + (guix-split-insert val face + guix-info-fill-column + (concat "\n" guix-info-multiline-prefix))) + +(defun guix-info-insert-val-simple (val &optional face-or-fun) + "Format and insert parameter value VAL at point. + +This function is intended to be called after +`guix-info-insert-title-simple'. + +If VAL is a one-line string longer than `guix-info-fill-column', +split it into several short lines and indent each line with +`guix-info-indent' spaces. + +If FACE-OR-FUN is a face, propertize inserted line(s) with this FACE. + +If FACE-OR-FUN is a function, call it with VAL as argument. If +VAL is a list, call the function on each element of this list." + (if (null val) + (progn (guix-info-insert-indent) + (guix-format-insert nil)) + (let ((prefix (concat "\n" (guix-info-get-indent)))) + (insert prefix) + (if (functionp face-or-fun) + (guix-mapinsert face-or-fun + (if (listp val) val (list val)) + prefix) + (guix-split-insert val face-or-fun + guix-info-fill-column prefix))))) + +(defun guix-info-insert-action-button (label action &optional message + &rest properties) + "Make action button with LABEL and insert it at point. +For the meaning of ACTION, MESSAGE and PROPERTIES, see +`guix-insert-button'." + (apply #'guix-insert-button + label 'guix-info-action-button action message + 'mouse-face 'guix-info-action-button-mouse + properties)) + +(defun guix-info-insert-file-path (path &optional _) + "Make button from file PATH and insert it at point." + (guix-insert-button + path 'guix-info-file-path + (lambda (btn) (find-file (button-label btn))) + "Find file")) + +(defun guix-info-insert-url (url &optional _) + "Make button from URL and insert it at point." + (guix-insert-button + url 'guix-info-url + (lambda (btn) (browse-url (button-label btn))) + "Browse URL")) + +(defun guix-info-insert-time (seconds &optional _) + "Insert formatted time string using SECONDS at point." + (guix-info-insert-val-default (guix-get-time-string seconds) + 'guix-info-time)) + + +(defvar guix-info-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent + map (make-composed-keymap button-buffer-map + special-mode-map)) + map) + "Parent keymap for info buffers.") + +(define-derived-mode guix-info-mode special-mode "Guix-Info" + "Parent mode for displaying information in info buffers.") + + +;;; Displaying packages + +(guix-define-buffer-type info package + :required (id installed non-unique)) + +(defface guix-package-info-name + '((t :inherit font-lock-keyword-face)) + "Face used for a name of a package." + :group 'guix-package-info) + +(defface guix-package-info-version + '((t :inherit font-lock-builtin-face)) + "Face used for a version of a package." + :group 'guix-package-info) + +(defface guix-package-info-synopsis + '((t :inherit font-lock-doc-face)) + "Face used for a synopsis of a package." + :group 'guix-package-info) + +(defface guix-package-info-description + '((t)) + "Face used for a description of a package." + :group 'guix-package-info) + +(defface guix-package-info-license + '((t :inherit font-lock-string-face)) + "Face used for a license of a package." + :group 'guix-package-info) + +(defface guix-package-info-location + '((t :inherit link)) + "Face used for a location of a package." + :group 'guix-package-info) + +(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) + +(defface guix-package-info-uninstalled-outputs + '((t :weight bold)) + "Face used for uninstalled outputs of a package." + :group 'guix-package-info) + +(defface guix-package-info-obsolete + '((t :inherit error)) + "Face used if a package is obsolete." + :group 'guix-package-info) + +(defun guix-package-info-insert-description (desc &optional _) + "Insert description DESC at point." + (guix-info-insert-val-simple desc 'guix-package-info-description)) + +(defun guix-package-info-insert-location (location &optional _) + "Make button from file LOCATION and insert it at point." + (guix-insert-button + location 'guix-package-info-location + (lambda (btn) (guix-find-location (button-label btn))) + "Find location of this package")) + +(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"))) + (fun (intern (concat "guix-package-info-insert-" type-name "inputs")))) + `(progn + (defface ,face + '((t :inherit button)) + ,(concat "Face used for " type-desc "inputs of a package.") + :group 'guix-package-info) + + (defun ,fun (inputs &optional _) + ,(concat "Make buttons from " type-desc "INPUTS and insert them at point.") + (guix-package-info-insert-full-names inputs ',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-full-names (names face) + "Make buttons from package NAMES and insert them at point. +NAMES is a list of strings. +Propertize buttons with FACE." + (if names + (guix-info-insert-val-default + (with-temp-buffer + (guix-mapinsert (lambda (name) + (guix-package-info-insert-full-name + name face)) + names + guix-list-separator) + (buffer-substring (point-min) (point-max)))) + (guix-format-insert nil))) + +(defun guix-package-info-insert-full-name (name face) + "Make button and insert package NAME at point. +Propertize package button with FACE." + (guix-insert-button + name face + (lambda (btn) + (guix-package-info-get-show 'name (button-label btn))) + "Describe this package")) + + +;;; Inserting outputs and installed parameters + +(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.") + +(defun guix-package-info-insert-outputs (outputs entry) + "Insert OUTPUTS from package ENTRY at point." + (and (guix-get-key-val entry 'obsolete) + (guix-package-info-insert-obsolete-text)) + (and (guix-get-key-val entry 'non-unique) + (guix-get-key-val entry 'installed) + (guix-package-info-insert-non-unique-text + (guix-get-full-name entry))) + (insert "\n") + (mapc (lambda (output) + (guix-package-info-insert-output output entry)) + outputs)) + +(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-package-info-insert-full-name full-name + 'guix-package-info-inputs) + (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-get-key-val entry 'installed)) + (obsolete (guix-get-key-val entry 'obsolete)) + (installed-entry (cl-find-if + (lambda (entry) + (string= (guix-get-key-val entry 'output) + output)) + installed)) + (action-type (if installed-entry 'delete 'install))) + (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) + (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 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-get-full-name entry output))) + (guix-info-insert-action-button + type-str + (lambda (btn) + (guix-process-package-actions + (list (button-get btn 'action-type) + (list (button-get btn 'id) + (button-get btn 'output))))) + (concat type-str " '" full-name "'") + 'action-type type + 'id (guix-get-key-val entry 'id) + 'output output))) + +(defun guix-package-info-insert-output-path (path &optional _) + "Insert PATH of the installed output." + (guix-info-insert-val-simple path #'guix-info-insert-file-path)) + +(defun guix-package-info-insert-output-dependencies (deps &optional _) + "Insert dependencies DEPS of the installed output." + (guix-info-insert-val-simple deps #'guix-info-insert-file-path)) + + +;;; Displaying generations + +(guix-define-buffer-type info generation) + +(defface guix-generation-info-number + '((t :inherit font-lock-keyword-face)) + "Face used for a number of a generation." + :group 'guix-generation-info) + +(declare-function guix-package-list-get-show "guix-list" t t) + +(defun guix-generation-info-insert-number (number &optional _) + "Insert generation NUMBER and action buttons." + (guix-info-insert-val-default number 'guix-generation-info-number) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Packages" + (lambda (btn) + (guix-package-list-get-show 'generation + (button-get btn 'number))) + "Show installed packages for this generation" + 'number number) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Delete" + (lambda (btn) (error "Sorry, not implemented yet")) + "Delete this generation")) + +(provide 'guix-info) + +;;; guix-info.el ends here diff --git a/emacs/guix-init.el.in b/emacs/guix-init.el.in new file mode 100644 index 0000000000..4e62728187 --- /dev/null +++ b/emacs/guix-init.el.in @@ -0,0 +1,14 @@ +(require 'guix-autoloads) + +(defvar guix-load-path + (replace-regexp-in-string "${prefix}" "@prefix@" "@emacsuidir@") + "Directory with scheme files for \"guix.el\" package.") + +(defvar guix-default-profile + (concat (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix") + "/profiles/per-user/" + (getenv "USER") + "/guix-profile") + "Default Guix profile.") + +(provide 'guix-init) diff --git a/emacs/guix-list.el b/emacs/guix-list.el new file mode 100644 index 0000000000..0460d20f1b --- /dev/null +++ b/emacs/guix-list.el @@ -0,0 +1,586 @@ +;;; guix-list.el --- List buffers for displaying entries -*- lexical-binding: t -*- + +;; 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 a list-like buffer for displaying information +;; about Guix packages and generations. + +;;; Code: + +(require 'cl-lib) +(require 'tabulated-list) +(require 'guix-info) +(require 'guix-history) +(require 'guix-base) +(require 'guix-utils) + +(defgroup guix-list nil + "General settings for list buffers." + :prefix "guix-list-" + :group 'guix) + +(defface guix-list-file-path + '((t :inherit guix-info-file-path)) + "Face used for file paths." + :group 'guix-list) + +(defcustom guix-list-describe-warning-count 10 + "The maximum number of entries for describing without a warning. +If a user wants to describe more than this number of marked +entries, he will be prompted for confirmation." + :type 'integer + :group 'guix-list) + +(defvar guix-list-column-format + `((package + (name 20 t) + (version 10 nil) + (outputs 13 t) + (installed 13 t) + (synopsis 30 nil)) + (generation + (number 5 + ,(lambda (a b) (guix-list-sort-numerically 0 a b)) + :right-align t) + (time 20 t) + (path 30 t))) + "Columns displayed in list buffers. +Each element of the list has a form: + + (ENTRY-TYPE . ((PARAM WIDTH SORT . PROPS) ...)) + +PARAM is the name of an entry parameter of ENTRY-TYPE. For the +meaning of WIDTH, SORT and PROPS, see `tabulated-list-format'.") + +(defvar guix-list-column-titles + '((generation + (number . "N."))) + "Column titles for list buffers. +Has the same structure as `guix-param-titles', but titles from +this list have a priority.") + +(defvar guix-list-column-value-methods + '((package + (name . guix-package-list-get-name) + (synopsis . guix-list-get-one-line) + (description . guix-list-get-one-line) + (installed . guix-package-list-get-installed-outputs)) + (generation + (time . guix-list-get-time) + (path . guix-list-get-file-path))) + "Methods for inserting parameter values in columns. +Each element of the list has a form: + + (ENTRY-TYPE . ((PARAM . FUN) ...)) + +PARAM is the name of an entry parameter of ENTRY-TYPE. + +FUN is 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 argument is an entry info (alist of +parameters and their values).") + +(defun guix-list-get-param-title (entry-type param) + "Return title of an ENTRY-TYPE entry parameter PARAM." + (or (guix-get-key-val guix-list-column-titles + entry-type param) + (guix-get-param-title entry-type param))) + +(defun guix-list-get-column-format (entry-type) + "Return column format for ENTRY-TYPE." + (guix-get-key-val guix-list-column-format entry-type)) + +(defun guix-list-get-displayed-params (entry-type) + "Return list of parameters of ENTRY-TYPE that should be displayed." + (mapcar #'car + (guix-list-get-column-format entry-type))) + +(defun guix-list-get-sort-key (entry-type param &optional invert) + "Return suitable sort key for `tabulated-list-sort-key'. +Define column title by ENTRY-TYPE and PARAM. If INVERT is +non-nil, invert the sort." + (when (memq param (guix-list-get-displayed-params entry-type)) + (cons (guix-list-get-param-title entry-type param) invert))) + +(defun guix-list-sort-numerically (column a b) + "Compare COLUMN of tabulated entries A and B numerically. +It is a sort predicate 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)))) + +(defun guix-list-make-tabulated-vector (entry-type fun) + "Call FUN on each column specification for ENTRY-TYPE. + +FUN is called with 2 argument: parameter name and column +specification (see `guix-list-column-format'). + +Return a vector made of values of FUN calls." + (apply #'vector + (mapcar (lambda (col-spec) + (funcall fun (car col-spec) (cdr col-spec))) + (guix-list-get-column-format entry-type)))) + +(defun guix-list-get-list-format (entry-type) + "Return ENTRY-TYPE list specification for `tabulated-list-format'." + (guix-list-make-tabulated-vector + entry-type + (lambda (param spec) + (cons (guix-list-get-param-title entry-type param) + spec)))) + +(defun guix-list-insert-entries (entries entry-type) + "Display ENTRIES of ENTRY-TYPE in the current list buffer. +ENTRIES should have a form of `guix-entries'." + (setq tabulated-list-entries + (guix-list-get-tabulated-entries entries entry-type)) + (tabulated-list-print)) + +(defun guix-list-get-tabulated-entries (entries entry-type) + "Return list of values of ENTRY-TYPE for `tabulated-list-entries'. +Values are taken from ENTRIES which should have the form of +`guix-entries'." + (mapcar (lambda (entry) + (list (guix-get-key-val entry 'id) + (guix-list-get-tabulated-entry entry entry-type))) + entries)) + +(defun guix-list-get-tabulated-entry (entry entry-type) + "Return array of values for `tabulated-list-entries'. +Parameters are taken from ENTRY of ENTRY-TYPE." + (guix-list-make-tabulated-vector + entry-type + (lambda (param _) + (let ((val (guix-get-key-val entry param)) + (fun (guix-get-key-val guix-list-column-value-methods + entry-type param))) + (if (and val fun) + (funcall fun val entry) + (guix-get-string val)))))) + +(defun guix-list-get-one-line (str &optional _) + "Return one-line string from a multi-line STR." + (guix-get-one-line str)) + +(defun guix-list-get-time (seconds &optional _) + "Return formatted time string from SECONDS." + (guix-get-time-string seconds)) + +(defun guix-list-get-file-path (path &optional _) + "Return PATH button specification for `tabulated-list-entries'." + (list path + 'face 'guix-list-file-path + 'action (lambda (btn) (find-file (button-label btn))) + 'follow-link t + 'help-echo "Find file")) + +(defun guix-list-current-id () + "Return ID of the current entry." + (or (tabulated-list-get-id) + (user-error "No entry here"))) + +(defun guix-list-current-entry () + "Return alist of the current entry info." + (guix-get-entry-by-id (guix-list-current-id) guix-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-mark-alist'. +ARGS is a list of additional values.") + +(defvar guix-list-mark-alist + '((empty . ?\s) + (general . ?*)) + "Alist of available mark names and mark characters.") + +(defsubst guix-list-get-mark (name) + "Return mark character by its NAME." + (or (guix-get-key-val guix-list-mark-alist name) + (error "Mark '%S' not found" name))) + +(defsubst 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-mark-alist' except the `empty' one." + (or mark-names + (setq mark-names + (delq 'empty + (mapcar #'car guix-list-mark-alist)))) + (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-mark-alist'. +If ADVANCE is non-nil, move forward by one line after marking. +Interactively, put a general mark and move to the next line." + (interactive '(general t)) + (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-all (mark-name) + "Mark all lines with MARK-NAME mark. +MARK-NAME is a symbol from `guix-list-mark-alist'. +Interactively, put a general mark on all lines." + (interactive '(general)) + (guix-list-for-each-line #'guix-list-mark mark-name)) + +(defun guix-list-unmark () + "Unmark the current line and move to the next line." + (interactive) + (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-mark-alist'." + (guix-list-for-each-line + (lambda () + (let ((mark-name (car (guix-get-key-val 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)) + + +(defvar guix-list-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map tabulated-list-mode-map) + (define-key map (kbd "m") 'guix-list-mark) + (define-key map (kbd "*") 'guix-list-mark) + (define-key map (kbd "M") 'guix-list-mark-all) + (define-key map (kbd "u") 'guix-list-unmark) + (define-key map (kbd "U") 'guix-list-unmark-all) + (define-key map (kbd "DEL") 'guix-list-unmark-backward) + (define-key map [remap tabulated-list-sort] 'guix-list-sort) + map) + "Parent keymap for list buffers.") + +(define-derived-mode guix-list-mode tabulated-list-mode "Guix-List" + "Parent mode for displaying information in list buffers." + (setq tabulated-list-padding 2)) + +(defmacro guix-list-define-entry-type (entry-type &rest args) + "Define common stuff for displaying ENTRY-TYPE entries in list buffers. + +Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The +following keywords are available: + + - `:sort-key' - default sort key for the tabulated list buffer. + + - `:invert-sort' - if non-nil, invert initial sort. + + - `:marks' - default value for the defined + `guix-ENTRY-TYPE-mark-alist' variable. + +This macro defines the following functions: + + - `guix-ENTRY-TYPE-describe' - display marked entries in info buffer. + + - `guix-ENTRY-TYPE-mark-MARK-NAME' functions for each mark + specified in `:marks' argument." + (let* ((entry-type-str (symbol-name entry-type)) + (entry-str (concat entry-type-str " entries")) + (prefix (concat "guix-" entry-type-str "-list")) + (mode-str (concat prefix "-mode")) + (init-fun (intern (concat prefix "-mode-initialize"))) + (describe-fun (intern (concat prefix "-describe"))) + (marks-var (intern (concat prefix "-mark-alist"))) + (marks-val nil) + (sort-key nil) + (invert-sort nil)) + + ;; Process the keyword args. + (while (keywordp (car args)) + (pcase (pop args) + (`:sort-key (setq sort-key (pop args))) + (`:invert-sort (setq invert-sort (pop args))) + (`:marks (setq marks-val (pop args))) + (_ (pop args)))) + + `(progn + (defvar ,marks-var ',marks-val + ,(concat "Alist of additional marks for `" mode-str "'.\n" + "Marks from this list are added to `guix-list-mark-alist'.")) + + ,@(mapcar (lambda (mark-spec) + (let* ((mark-name (car mark-spec)) + (mark-name-str (symbol-name mark-name))) + `(defun ,(intern (concat prefix "-mark-" mark-name-str "-simple")) () + ,(concat "Put '" mark-name-str "' mark and move to the next line.\n" + "Also add the current entry to `guix-list-marked'.") + (interactive) + (guix-list-mark ',mark-name t)))) + marks-val) + + (defun ,describe-fun (&optional arg) + ,(concat "Describe " entry-str " marked with a general mark.\n" + "If no entry is marked, describe the current " entry-type-str ".\n" + "With prefix (if ARG is non-nil), describe the " entry-str "\n" + "marked with any mark.") + (interactive "P") + (let* ((ids (or (apply #'guix-list-get-marked-id-list + (unless arg '(general))) + (list (guix-list-current-id)))) + (count (length ids))) + (when (or (<= count guix-list-describe-warning-count) + (y-or-n-p (format "Do you really want to describe %d entries? " + count))) + (,(intern (concat "guix-" entry-type-str "-info-get-show")) + 'id ids)))) + + (defun ,init-fun () + ,(concat "Initial settings for `" mode-str "'.") + ,(when sort-key + `(setq tabulated-list-sort-key + (guix-list-get-sort-key + ',entry-type ',sort-key ,invert-sort))) + (setq tabulated-list-format + (guix-list-get-list-format ',entry-type)) + (setq-local guix-list-mark-alist + (append guix-list-mark-alist ,marks-var)) + (tabulated-list-init-header))))) + +(put 'guix-list-define-entry-type 'lisp-indent-function 'defun) + + +;;; Displaying packages + +(guix-define-buffer-type list package) + +(guix-list-define-entry-type package + :sort-key name + :marks ((install . ?I) + (upgrade . ?U) + (delete . ?D))) + +(defface guix-package-list-obsolete + '((t :inherit guix-package-info-obsolete)) + "Face used if a package is obsolete." + :group 'guix-package-list) + +(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) + +(let ((map guix-package-list-mode-map)) + (define-key map (kbd "RET") 'guix-package-list-describe) + (define-key map (kbd "x") 'guix-package-list-execute) + (define-key map (kbd "i") 'guix-package-list-mark-install) + (define-key map (kbd "^") 'guix-package-list-mark-upgrade) + (define-key map (kbd "d") 'guix-package-list-mark-delete)) + +(defun guix-package-list-get-name (name entry) + "Return NAME of the package ENTRY. +Colorize it with `guix-package-list-obsolete' if needed." + (guix-get-string name + (when (guix-get-key-val entry 'obsolete) + 'guix-package-list-obsolete))) + +(defun guix-package-list-get-installed-outputs (installed &optional _) + "Return string with outputs from INSTALLED entries." + (guix-get-string + (mapcar (lambda (entry) + (guix-get-key-val 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) + (derived-mode-p 'guix-package-list-mode) + (eq guix-search-type 'generation)) + (error "Action marks are disabled for lists of 'generation packages'"))) + +(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)) + (available (guix-get-key-val entry 'outputs)) + (installed (guix-get-installed-outputs entry)) + (to-install (if arg + (guix-completing-read-multiple + "Output(s) to install: " available nil t) + '("out"))) + (to-install (cl-set-difference to-install installed + :test #'string=))) + (if to-install + (apply #'guix-list-mark 'install t to-install) + (user-error "This package is already installed")))) + +(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-get-installed-outputs entry))) + (or installed + (user-error "This package is not installed")) + (let ((to-delete (when arg + (guix-completing-read-multiple + "Output(s) to delete: " installed nil t)))) + (if to-delete + (apply #'guix-list-mark 'delete t to-delete) + (guix-package-list-mark-delete-simple))))) + +(defun guix-package-list-mark-upgrade () + "Mark the current package for upgrading and move to the next line." + (interactive) + (guix-package-list-marking-check) + (let ((entry (guix-list-current-entry))) + (or (guix-get-installed-outputs entry) + (user-error "This package is not installed")) + (when (or (guix-get-key-val entry 'obsolete) + (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) + (guix-package-list-mark-upgrade-simple)))) + +(defun guix-package-list-execute () + "Perform actions on the marked packages." + (interactive) + (let ((actions (delq nil + (mapcar #'guix-package-list-make-action + '(install delete upgrade))))) + (if actions + (apply #'guix-process-package-actions actions) + (user-error "No operations specified")))) + +(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)))) + + +;;; Displaying generations + +(guix-define-buffer-type list generation) + +(guix-list-define-entry-type generation + :sort-key number + :invert-sort 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 "i") 'guix-generation-list-describe) + (define-key map (kbd "d") 'guix-generation-list-mark-delete-simple)) + +(defun guix-generation-list-show-packages () + "List installed packages for the generation at point." + (interactive) + (guix-package-list-get-show 'generation (guix-list-current-id))) + +(provide 'guix-list) + +;;; guix-list.el ends here diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm new file mode 100644 index 0000000000..1383d08830 --- /dev/null +++ b/emacs/guix-main.scm @@ -0,0 +1,603 @@ +;;; 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: + +;; 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. These alists are called "entries" in +;; this code. So to distinguish, just "package" in the name of a +;; function means a guile object ("package" record) while +;; "package entry" means alist of package parameters and values (see +;; ‘package-param-alist’). +;; +;; "Entry" is probably not the best name for such alists, because there +;; already exists "manifest-entry" which has nothing to do with the +;; "entry" described above. Do not be confused :) + +;; ‘get-entries’ function 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. +;; +;; Important: as object addresses live only during guile session, elisp +;; part should take care about updating information after "Guix REPL" is +;; restarted (TODO!) +;; +;; ‘installed’ parameter of a package entry contains information about +;; installed outputs. It is a list of "installed entries" (see +;; ‘package-installed-param-alist’). + +;; To speed-up the process of getting information, the following +;; auxiliary variables are used: +;; +;; - `%packages' - VHash of "package address"/"package" pairs. +;; +;; - `%package-table' - Hash table of +;; "name+version key"/"list of packages" pairs. +;; +;; - `%current-manifest-entries-table' - Hash table of +;; "name+version key"/"list of manifest entries" pairs. This variable +;; is set by `set-current-manifest-maybe!' when it is needed. + +;;; Code: + +(use-modules + (ice-9 vlist) + (ice-9 match) + (srfi srfi-1) + (srfi srfi-11) + (srfi srfi-19) + (srfi srfi-26) + (guix) + (guix packages) + (guix profiles) + (guix licenses) + (guix utils) + (guix ui) + (guix scripts package) + (gnu packages)) + +(define-syntax-rule (first-or-false lst) + (and (not (null? lst)) + (first lst))) + +(define full-name->name+version package-name->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 name+version->key cons) +(define key->name+version car+cdr) + +(define %current-manifest #f) +(define %current-manifest-entries-table #f) + +(define %packages + (fold-packages (lambda (pkg res) + (vhash-consq (object-address pkg) pkg res)) + vlist-null)) + +(define %package-table + (let ((table (make-hash-table (vlist-length %packages)))) + (vlist-for-each + (lambda (elem) + (match elem + ((address . pkg) + (let* ((key (name+version->key (package-name pkg) + (package-version pkg))) + (ref (hash-ref table key))) + (hash-set! table key + (if ref (cons pkg ref) (list pkg))))))) + %packages) + table)) + +;; FIXME get rid of this function! +(define (set-current-manifest-maybe! profile) + (define (manifest-entries->hash-table entries) + (let ((entries-table (make-hash-table (length entries)))) + (for-each (lambda (entry) + (let* ((key (name+version->key + (manifest-entry-name entry) + (manifest-entry-version entry))) + (ref (hash-ref entries-table key))) + (hash-set! entries-table key + (if ref (cons entry ref) (list entry))))) + entries) + entries-table)) + + (when profile + (let ((manifest (profile-manifest profile))) + (unless (and (manifest? %current-manifest) + (equal? manifest %current-manifest)) + (set! %current-manifest manifest) + (set! %current-manifest-entries-table + (manifest-entries->hash-table + (manifest-entries manifest))))))) + +(define (manifest-entries-by-name+version name version) + (or (hash-ref %current-manifest-entries-table + (name+version->key name version)) + '())) + +(define (packages-by-name+version name version) + (or (hash-ref %package-table + (name+version->key name version)) + '())) + +(define (packages-by-full-name full-name) + (call-with-values + (lambda () (full-name->name+version full-name)) + packages-by-name+version)) + +(define (package-by-address address) + (and=> (vhash-assq address %packages) + cdr)) + +(define (packages-by-id id) + (if (integer? id) + (let ((pkg (package-by-address id))) + (if pkg (list pkg) '())) + (packages-by-full-name 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 (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 (fold-manifest-entries proc init) + "Fold over `%current-manifest-entries-table'. +Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash +table, using INIT as the initial value of RESULT." + (hash-fold (lambda (key entries res) + (let-values (((name version) (key->name+version key))) + (proc name version entries res))) + init + %current-manifest-entries-table)) + +(define (fold-object proc init obj) + (fold proc init + (if (list? obj) obj (list obj)))) + +(define* (object-transformer param-alist #:optional (params '())) + "Return function for transforming an object into alist of parameters/values. + +PARAM-ALIST is alist of available object parameters (symbols) and functions +returning values of these parameters. Each function is called with object as +a single argument. + +PARAMS is list of parameters from PARAM-ALIST that should be returned by a +resulting function. 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 ((alist (let ((use-all-params (null? params))) + (filter-map (match-lambda + ((param . fun) + (and (or use-all-params + (memq param params)) + (cons param fun))) + (_ #f)) + param-alist)))) + (lambda (object) + (map (match-lambda + ((param . fun) + (cons param (fun object)))) + alist)))) + +(define package-installed-param-alist + (list + (cons 'output manifest-entry-output) + (cons 'path manifest-entry-item) + (cons 'dependencies manifest-entry-dependencies))) + +(define manifest-entry->installed-entry + (object-transformer package-installed-param-alist)) + +(define (manifest-entries->installed-entries entries) + (map manifest-entry->installed-entry entries)) + +(define (installed-entries-by-name+version name version) + (manifest-entries->installed-entries + (manifest-entries-by-name+version name version))) + +(define (installed-entries-by-package package) + (installed-entries-by-name+version (package-name package) + (package-version package))) + +(define (package-inputs-names inputs) + "Return list of full names of the packages from package INPUTS." + (filter-map (match-lambda + ((_ (? package? package)) + (package-full-name package)) + (_ #f)) + inputs)) + +(define (package-license-names package) + "Return list of license names of the PACKAGE." + (fold-object (lambda (license res) + (if (license? license) + (cons (license-name license) res) + res)) + '() + (package-license package))) + +(define (package-unique? package) + "Return #t if PACKAGE is a single package with such name/version." + (null? (cdr (packages-by-name+version (package-name package) + (package-version package))))) + +(define package-param-alist + (list + (cons 'id object-address) + (cons 'name package-name) + (cons 'version package-version) + (cons 'license package-license-names) + (cons 'synopsis package-synopsis) + (cons 'description package-description) + (cons 'home-url package-home-page) + (cons 'outputs package-outputs) + (cons 'non-unique (negate package-unique?)) + (cons 'inputs (lambda (pkg) (package-inputs-names + (package-inputs pkg)))) + (cons 'native-inputs (lambda (pkg) (package-inputs-names + (package-native-inputs pkg)))) + (cons 'propagated-inputs (lambda (pkg) (package-inputs-names + (package-propagated-inputs pkg)))) + (cons 'location (lambda (pkg) (location->string + (package-location pkg)))) + (cons 'installed installed-entries-by-package))) + +(define (package-param package param) + "Return the value of a PACKAGE PARAM." + (define (accessor param) + (and=> (assq param package-param-alist) + cdr)) + (and=> (accessor param) + (cut <> package))) + +(define (matching-package-entries ->entry predicate) + "Return list of package entries for the matching packages. +PREDICATE is called on each package." + (fold-packages (lambda (pkg res) + (if (predicate pkg) + (cons (->entry pkg) res) + res)) + '())) + +(define (make-obsolete-package-entry name version entries) + "Return package entry for an obsolete package with NAME and VERSION. +ENTRIES is a list of manifest entries used to get installed info." + `((id . ,(name+version->full-name name version)) + (name . ,name) + (version . ,version) + (outputs . ,(map manifest-entry-output entries)) + (obsolete . #t) + (installed . ,(manifest-entries->installed-entries entries)))) + +(define (package-entries-by-name+version ->entry name version) + "Return list of package entries for packages with NAME and VERSION." + (let ((packages (packages-by-name+version name version))) + (if (null? packages) + (let ((entries (manifest-entries-by-name+version name version))) + (if (null? entries) + '() + (list (make-obsolete-package-entry name version entries)))) + (map ->entry packages)))) + +(define (package-entries-by-spec profile ->entry spec) + "Return list of package entries for packages with name specification SPEC." + (set-current-manifest-maybe! profile) + (let-values (((name version) + (full-name->name+version spec))) + (if version + (package-entries-by-name+version ->entry name version) + (matching-package-entries + ->entry + (lambda (pkg) (string=? name (package-name pkg))))))) + +(define (package-entries-by-regexp profile ->entry regexp match-params) + "Return list of package entries for 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)) + + (set-current-manifest-maybe! profile) + (let ((re (make-regexp regexp regexp/icase))) + (matching-package-entries ->entry (cut package-match? <> re)))) + +(define (package-entries-by-ids profile ->entry ids) + "Return list of package entries for packages matching KEYS. +IDS may be an object-address, a full-name or a list of such elements." + (set-current-manifest-maybe! profile) + (fold-object + (lambda (id res) + (if (integer? id) + (let ((pkg (package-by-address id))) + (if pkg + (cons (->entry pkg) res) + res)) + (let ((entries (package-entries-by-spec #f ->entry id))) + (if (null? entries) + res + (append res entries))))) + '() + ids)) + +(define (newest-available-package-entries profile ->entry) + "Return list of package entries for the newest available packages." + (set-current-manifest-maybe! profile) + (vhash-fold (lambda (name elem res) + (match elem + ((version newest pkgs ...) + (cons (->entry newest) res)))) + '() + (find-newest-available-packages))) + +(define (all-available-package-entries profile ->entry) + "Return list of package entries for all available packages." + (set-current-manifest-maybe! profile) + (matching-package-entries ->entry (const #t))) + +(define (manifest-package-entries ->entry) + "Return list of package entries for the current manifest." + (fold-manifest-entries + (lambda (name version entries res) + ;; We don't care about duplicates for the list of + ;; installed packages, so just take any package (car) + ;; matching name+version + (cons (car (package-entries-by-name+version ->entry name version)) + res)) + '())) + +(define (installed-package-entries profile ->entry) + "Return list of package entries for all installed packages." + (set-current-manifest-maybe! profile) + (manifest-package-entries ->entry)) + +(define (generation-package-entries profile ->entry generation) + "Return list of package entries for packages from GENERATION." + (set-current-manifest-maybe! + (generation-file-name profile generation)) + (manifest-package-entries ->entry)) + +(define (obsolete-package-entries profile _) + "Return list of package entries for obsolete packages." + (set-current-manifest-maybe! profile) + (fold-manifest-entries + (lambda (name version entries res) + (let ((packages (packages-by-name+version name version))) + (if (null? packages) + (cons (make-obsolete-package-entry name version entries) res) + res))) + '())) + + +;;; Generation entries + +(define (profile-generations profile) + "Return list of generations for PROFILE." + (let ((generations (generation-numbers profile))) + (if (equal? generations '(0)) + '() + generations))) + +(define (generation-param-alist profile) + "Return alist of generation parameters and functions for PROFILE." + (list + (cons 'id identity) + (cons 'number identity) + (cons 'prev-number (cut previous-generation-number profile <>)) + (cons 'path (cut generation-file-name profile <>)) + (cons 'time (lambda (gen) + (time-second (generation-time profile gen)))))) + +(define (matching-generation-entries profile ->entry predicate) + "Return list of generation entries for the matching generations. +PREDICATE is called on each generation." + (filter-map (lambda (gen) + (and (predicate gen) (->entry gen))) + (profile-generations profile))) + +(define (last-generation-entries profile ->entry number) + "Return list of last NUMBER generation entries. +If NUMBER is 0 or less, return all generation entries." + (let ((generations (profile-generations profile)) + (number (if (<= number 0) +inf.0 number))) + (map ->entry + (if (> (length generations) number) + (list-head (reverse generations) number) + generations)))) + +(define (all-generation-entries profile ->entry) + "Return list of all generation entries." + (last-generation-entries profile ->entry +inf.0)) + +(define (generation-entries-by-ids profile ->entry ids) + "Return list of generation entries for generations matching IDS. +IDS is a list of generation numbers." + (matching-generation-entries profile ->entry (cut memq <> ids))) + + +;;; Getting package/generation entries + +(define %package-entries-functions + (alist->vhash + `((id . ,package-entries-by-ids) + (name . ,package-entries-by-spec) + (regexp . ,package-entries-by-regexp) + (all-available . ,all-available-package-entries) + (newest-available . ,newest-available-package-entries) + (installed . ,installed-package-entries) + (obsolete . ,obsolete-package-entries) + (generation . ,generation-package-entries)) + hashq)) + +(define %generation-entries-functions + (alist->vhash + `((id . ,generation-entries-by-ids) + (last . ,last-generation-entries) + (all . ,all-generation-entries)) + hashq)) + +(define (get-entries profile params entry-type search-type search-vals) + "Return list of entries. +ENTRY-TYPE and SEARCH-TYPE define a search function that should be +applied to PARAMS and VALS." + (let-values (((vhash ->entry) + (case entry-type + ((package) + (values %package-entries-functions + (object-transformer + package-param-alist params))) + ((generation) + (values %generation-entries-functions + (object-transformer + (generation-param-alist profile) params))) + (else (format (current-error-port) + "Wrong entry type '~a'" entry-type))))) + (match (vhash-assq search-type vhash) + ((key . fun) + (apply fun profile ->entry search-vals)) + (_ '())))) + + +;;; Actions + +(define* (package->manifest-entry* package #:optional output) + (and package + (begin + (check-package-freshness 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)) + (let* ((store (open-connection)) + (derivation (run-with-store + store (profile-derivation new-manifest))) + (derivations (list derivation)) + (new-profile (derivation->output-path derivation))) + (set-build-options store + #:use-substitutes? use-substitutes?) + (manifest-show-transaction store manifest transaction + #:dry-run? dry-run?) + (show-what-to-build store derivations + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + (unless dry-run? + (let ((name (generation-file-name + profile + (+ 1 (generation-number profile))))) + (and (build-derivations store derivations) + (let* ((entries (manifest-entries new-manifest)) + (count (length entries))) + (switch-symlinks name new-profile) + (switch-symlinks profile name) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count))))))))) + diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el new file mode 100644 index 0000000000..c1fe1a3a38 --- /dev/null +++ b/emacs/guix-utils.el @@ -0,0 +1,160 @@ +;;; guix-utils.el --- General utility functions + +;; 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 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 '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)) + +(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)))) + +(defun guix-mapinsert (function sequence separator) + "Like `mapconcat' but for inserting text. +Apply FUNCTION to each element of SEQUENCE, and insert SEPARATOR +at point between each FUNCTION call." + (when sequence + (funcall function (car sequence)) + (mapc (lambda (obj) + (insert separator) + (funcall function obj)) + (cdr sequence)))) + +(defun guix-insert-button (label face action &optional message + &rest properties) + "Make button with LABEL and insert it at point. +Propertize button with FACE. +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." + (if (null label) + (guix-format-insert nil) + (apply #'insert-text-button + label + 'face face + 'action action + 'follow-link t + 'help-echo message + properties))) + +(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 and STR is a one-line string longer than COL, +split it into several short lines." + (let ((strings (split-string str "\n *"))) + (if (and col + (null (cdr strings)) ; if not multi-line + (> (length str) col)) + (split-string (guix-get-filled-string str col) "\n") + strings))) + +(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-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=)) + +(defun guix-get-key-val (alist &rest keys) + "Return value from ALIST by KEYS. +ALIST is alist of alists of alists ... which can be consecutively +accessed with KEYS." + (let ((val alist)) + (dolist (key keys val) + (setq val (cdr (assq key val)))))) + +(provide 'guix-utils) + +;;; guix-utils.el ends here diff --git a/emacs/guix.el b/emacs/guix.el new file mode 100644 index 0000000000..7336f6732e --- /dev/null +++ b/emacs/guix.el @@ -0,0 +1,141 @@ +;;; guix.el --- Interface for GNU Guix package manager + +;; Copyright © 2014 Alex Kost <alezost@gmail.com> + +;; Package-Requires: ((geiser "0.3")) +;; Keywords: tools + +;; 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 an interface for searching, listing and getting +;; information about Guix packages and generations; and for +;; installing/upgrading/removing packages. + +;;; Code: + +(require 'guix-list) +(require 'guix-info) + +(defgroup guix nil + "Interface for Guix package manager." + :prefix "guix-" + :group 'external) + +(defcustom guix-list-single-package nil + "If non-nil, list a package even if it is the only matching result. +If nil, show a single package in the info buffer." + :type 'boolean + :group 'guix) + +(defcustom guix-show-generations-function 'guix-generation-list-get-show + "Default function used to display generations." + :type '(choice (function-item guix-generation-list-get-show) + (function-item guix-generation-info-get-show)) + :group 'guix) + +(defvar guix-search-params '(name synopsis description) + "Default list of package parameters for searching by regexp.") + +(defvar guix-search-history nil + "A history of minibuffer prompts.") + +(defun guix-get-show-packages (search-type &rest search-vals) + "Search for packages and show results. + +See `guix-get-entries' for the meaning of SEARCH-TYPE and +SEARCH-VALS. + +Results are displayed in the list buffer, unless a single package +is found and `guix-list-single-package' is nil." + (let* ((list-params (guix-package-list-get-params-for-receiving)) + (packages (guix-get-entries 'package search-type + search-vals list-params))) + (if (or guix-list-single-package + (cdr packages)) + (guix-package-list-set packages search-type search-vals) + (let ((info-params (guix-package-info-get-params-for-receiving))) + (unless (equal list-params info-params) + ;; If we don't have required info, we should receive it again + (setq packages (guix-get-entries 'package search-type + search-vals info-params)))) + (guix-package-info-set packages search-type search-vals)))) + +(defun guix-get-show-generations (search-type &rest search-vals) + "Search for generations and show results." + (apply guix-show-generations-function search-type search-vals)) + +;;;###autoload +(defun guix-search-by-name (name) + "Search for Guix packages by NAME. +NAME is a string with name specification. It may optionally contain +a version number. Examples: \"guile\", \"guile-2.0.11\"." + (interactive + (list (read-string "Package name: " nil 'guix-search-history))) + (guix-get-show-packages 'name name)) + +;;;###autoload +(defun guix-search-by-regexp (regexp &rest params) + "Search for Guix packages by REGEXP. +PARAMS are package parameters that should be searched. +If PARAMS are not specified, use `guix-search-params'." + (interactive + (list (read-string "Regexp: " nil 'guix-search-history))) + (or params (setq params guix-search-params)) + (guix-get-show-packages 'regexp regexp params)) + +;;;###autoload +(defun guix-installed-packages () + "Display information about installed Guix packages." + (interactive) + (guix-get-show-packages 'installed)) + +;;;###autoload +(defun guix-obsolete-packages () + "Display information about obsolete Guix packages." + (interactive) + (guix-get-show-packages 'obsolete)) + +;;;###autoload +(defun guix-all-available-packages () + "Display information about all available Guix packages." + (interactive) + (guix-get-show-packages 'all-available)) + +;;;###autoload +(defun guix-newest-available-packages () + "Display information about the newest available Guix packages." + (interactive) + (guix-get-show-packages 'newest-available)) + +;;;###autoload +(defun guix-generations (&optional number) + "Display information about last NUMBER generations. +If NUMBER is nil, display all generations. + +Generations can be displayed in a list or info buffers depending +on `guix-show-generations-function'. + +Interactively, NUMBER is defined by a numeric prefix." + (interactive "P") + (if (numberp number) + (guix-get-show-generations 'last number) + (guix-get-show-generations 'all))) + +(provide 'guix) + +;;; guix.el ends here |