diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2016-01-03 14:53:03 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2016-01-03 14:53:03 +0100 |
| commit | 53334dd6e9e296e17110ebcd2b1f93f117ffe36a (patch) | |
| tree | 2653db2eab9a204dab892ea8b6812cadf7209e84 /emacs | |
| parent | 1575dcd134f4fae7255787293f4988bbd043de95 (diff) | |
| parent | 51385362f76e2f823ac8d8cf720d06c386504069 (diff) | |
| download | guix-53334dd6e9e296e17110ebcd2b1f93f117ffe36a.tar.gz | |
Merge branch 'master' into core-updates
Diffstat (limited to 'emacs')
| -rw-r--r-- | emacs/guix-backend.el | 68 | ||||
| -rw-r--r-- | emacs/guix-base.el | 863 | ||||
| -rw-r--r-- | emacs/guix-buffer.el | 622 | ||||
| -rw-r--r-- | emacs/guix-command.el | 9 | ||||
| -rw-r--r-- | emacs/guix-entry.el | 59 | ||||
| -rw-r--r-- | emacs/guix-external.el | 8 | ||||
| -rw-r--r-- | emacs/guix-hydra-build.el | 362 | ||||
| -rw-r--r-- | emacs/guix-hydra-jobset.el | 162 | ||||
| -rw-r--r-- | emacs/guix-hydra.el | 363 | ||||
| -rw-r--r-- | emacs/guix-info.el | 1007 | ||||
| -rw-r--r-- | emacs/guix-list.el | 960 | ||||
| -rw-r--r-- | emacs/guix-main.scm | 4 | ||||
| -rw-r--r-- | emacs/guix-messages.el | 26 | ||||
| -rw-r--r-- | emacs/guix-read.el | 123 | ||||
| -rw-r--r-- | emacs/guix-ui-generation.el | 433 | ||||
| -rw-r--r-- | emacs/guix-ui-package.el | 955 | ||||
| -rw-r--r-- | emacs/guix-ui.el | 333 | ||||
| -rw-r--r-- | emacs/guix-utils.el | 269 | ||||
| -rw-r--r-- | emacs/guix.el | 213 |
19 files changed, 4294 insertions, 2545 deletions
diff --git a/emacs/guix-backend.el b/emacs/guix-backend.el index 82383e48ff..0736f85ec8 100644 --- a/emacs/guix-backend.el +++ b/emacs/guix-backend.el @@ -36,18 +36,13 @@ ;; 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 +;; auxiliary scheme-files for "guix.el". You can just use +;; `geiser-connect-local' command with `guix-repl-current-socket' to ;; have a usual Geiser REPL with all stuff defined by "guix.el" package. ;;; Code: @@ -98,11 +93,17 @@ 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 +(defcustom guix-repl-socket-file-name-function + #'guix-repl-socket-file-name + "Function used to define a socket file name used by Guix REPL. +The function is called without arguments." + :type '(choice (function-item guix-repl-socket-file-name) + (function :tag "Other function")) :group 'guix-repl) +(defvar guix-repl-current-socket nil + "Name of a socket file used by the current Guix REPL.") + (defvar guix-repl-buffer nil "Main Geiser REPL buffer used for communicating with Guix. This REPL is used for processing package actions and for @@ -139,17 +140,28 @@ See `guix-eval-in-repl' for details.") "Message telling about successful Guix operation." (message "Guix operation has been performed.")) -(defun guix-get-guile-program (&optional internal) +(defun guix-get-guile-program (&optional socket) "Return a value suitable for `geiser-guile-binary'." - (if (or internal - (not guix-use-guile-server)) + (if (null socket) 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)))))) + (list (concat "--listen=" socket))))) + +(defun guix-repl-socket-file-name () + "Return a name of a socket file used by Guix REPL." + (make-temp-name + (concat (file-name-as-directory temporary-file-directory) + "guix-repl-"))) + +(defun guix-repl-delete-socket-maybe () + "Delete `guix-repl-current-socket' file if it exists." + (and guix-repl-current-socket + (file-exists-p guix-repl-current-socket) + (delete-file guix-repl-current-socket))) + +(add-hook 'kill-emacs-hook 'guix-repl-delete-socket-maybe) (defun guix-start-process-maybe (&optional start-msg end-msg) "Start Geiser REPL configured for Guix if needed. @@ -176,19 +188,21 @@ display messages." (get-buffer-process repl)) (and start-msg (message start-msg)) (setq guix-repl-operation-p nil) - (let ((geiser-guile-binary (guix-get-guile-program internal)) - (geiser-guile-init-file (or internal guix-helper-file)) + (unless internal + ;; Guile leaves socket file after exit, so remove it if it + ;; exists (after the REPL restart). + (guix-repl-delete-socket-maybe) + (setq guix-repl-current-socket + (and guix-use-guile-server + (or guix-repl-current-socket + (funcall guix-repl-socket-file-name-function))))) + (let ((geiser-guile-binary (guix-get-guile-program + (unless internal + guix-repl-current-socket))) + (geiser-guile-init-file (unless internal guix-helper-file)) (repl (get-buffer-create (guix-get-repl-buffer-name internal)))) - (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)))) + (guix-start-repl repl (and internal guix-repl-current-socket)) (set repl-var repl) (and end-msg (message end-msg)) (unless internal diff --git a/emacs/guix-base.el b/emacs/guix-base.el index d9c70aae9e..dae658ebfa 100644 --- a/emacs/guix-base.el +++ b/emacs/guix-base.el @@ -22,124 +22,32 @@ ;; 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-profiles) (require 'guix-backend) (require 'guix-guile) +(require 'guix-read) (require 'guix-utils) -(require 'guix-history) -(require 'guix-messages) - - -;;; Parameters of the entries - -(defvar guix-param-titles - '((package - (id . "ID") - (name . "Name") - (version . "Version") - (source . "Source") - (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")) - (output - (id . "ID") - (name . "Name") - (version . "Version") - (source . "Source") - (license . "License") - (synopsis . "Synopsis") - (description . "Description") - (home-url . "Home page") - (output . "Output") - (inputs . "Inputs") - (native-inputs . "Native inputs") - (propagated-inputs . "Propagated inputs") - (location . "Location") - (installed . "Installed") - (path . "Installed path") - (dependencies . "Dependencies")) - (generation - (id . "ID") - (number . "Number") - (prev-number . "Previous number") - (current . "Current") - (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: +(require 'guix-ui) - (ENTRY-TYPE . ((PARAM . TITLE) ...))") +(defgroup guix nil + "Settings for Guix package manager and friends." + :prefix "guix-" + :group 'external) -(defun guix-get-param-title (entry-type param) - "Return title of an ENTRY-TYPE entry parameter PARAM." - (or (guix-assq-value guix-param-titles - entry-type param) - (prog1 (symbol-name param) - (message "Couldn't find title for '%S %S'." - entry-type param)))) +(defgroup guix-faces nil + "Guix faces." + :group 'guix + :group 'faces) -(defun guix-get-name-spec (name version &optional output) +(defun guix-package-name-specification (name version &optional output) "Return Guix package specification by its NAME, VERSION and OUTPUT." (concat name "-" version (when output (concat ":" output)))) -(defun guix-get-full-name (entry &optional output) - "Return name specification of the package ENTRY and OUTPUT." - (guix-get-name-spec (guix-assq-value entry 'name) - (guix-assq-value entry 'version) - output)) - -(defun guix-entry-to-specification (entry) - "Return name specification by the package or output ENTRY." - (guix-get-name-spec (guix-assq-value entry 'name) - (guix-assq-value entry 'version) - (guix-assq-value entry 'output))) - -(defun guix-entries-to-specifications (entries) - "Return name specifications by the package or output ENTRIES." - (cl-remove-duplicates (mapcar #'guix-entry-to-specification entries) - :test #'string=)) - -(defun guix-get-installed-outputs (entry) - "Return list of installed outputs for the package ENTRY." - (mapcar (lambda (installed-entry) - (guix-assq-value installed-entry 'output)) - (guix-assq-value 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-assq-value entry 'id))) - entries)) - -(defun guix-get-package-id-and-output-by-output-id (oid) - "Return list (PACKAGE-ID OUTPUT) by output id OID." - (cl-multiple-value-bind (pid-str output) - (split-string oid ":") - (let ((pid (string-to-number pid-str))) - (list (if (= 0 pid) pid-str pid) - output)))) - -;;; Location of the packages +;;; Location of packages, profiles and manifests (defvar guix-directory nil "Default Guix directory. @@ -179,538 +87,6 @@ For the meaning of location, see `guix-find-location'." (guix-eval-read (guix-make-guile-expression 'package-location-string id-or-name))) - -;;; Receivable lists of packages, lint checkers, etc. - -(guix-memoized-defun guix-graph-type-names () - "Return a list of names of available graph node types." - (guix-eval-read (guix-make-guile-expression 'graph-type-names))) - -(guix-memoized-defun guix-refresh-updater-names () - "Return a list of names of available refresh updater types." - (guix-eval-read (guix-make-guile-expression 'refresh-updater-names))) - -(guix-memoized-defun guix-lint-checker-names () - "Return a list of names of available lint checkers." - (guix-eval-read (guix-make-guile-expression 'lint-checker-names))) - -(guix-memoized-defun guix-package-names () - "Return a list of names of available packages." - (sort - ;; Work around <https://github.com/jaor/geiser/issues/64>: - ;; list of strings is parsed much slower than list of lists, - ;; so we use 'package-names-lists' instead of 'package-names'. - - ;; (guix-eval-read (guix-make-guile-expression 'package-names)) - - (mapcar #'car - (guix-eval-read (guix-make-guile-expression - 'package-names-lists))) - #'string<)) - - -;;; Buffers and auto updating. - -(defcustom guix-update-after-operation 'current - "Define what information to update after executing an operation. - -After successful executing an operation in the Guix REPL (for -example after installing a package), information in Guix buffers -will or will not be automatically updated depending on a value of -this variable. - -If nil, update nothing (do not revert any buffer). -If `current', update the buffer from which an operation was performed. -If `all', update all Guix buffers (not recommended)." - :type '(choice (const :tag "Do nothing" nil) - (const :tag "Update operation buffer" current) - (const :tag "Update all Guix buffers" all)) - :group 'guix) - -(defcustom guix-buffer-name-function #'guix-buffer-name-default - "Function used to define name of a buffer for displaying information. -The function is called with 4 arguments: PROFILE, BUFFER-TYPE, -ENTRY-TYPE, SEARCH-TYPE. See `guix-get-entries' for the meaning -of the arguments." - :type '(choice (function-item guix-buffer-name-default) - (function-item guix-buffer-name-simple) - (function :tag "Other function")) - :group 'guix) - -(defun guix-buffer-name-simple (_profile buffer-type entry-type - &optional _search-type) - "Return name of a buffer used for displaying information. -The name is defined by `guix-ENTRY-TYPE-BUFFER-TYPE-buffer-name' -variable." - (symbol-value - (guix-get-symbol "buffer-name" buffer-type entry-type))) - -(defun guix-buffer-name-default (profile buffer-type entry-type - &optional _search-type) - "Return name of a buffer used for displaying information. -The name is almost the same as the one defined by -`guix-buffer-name-simple' except the PROFILE name is added to it." - (let ((simple-name (guix-buffer-name-simple - profile buffer-type entry-type)) - (profile-name (file-name-base (directory-file-name profile))) - (re (rx string-start - (group (? "*")) - (group (*? any)) - (group (? "*")) - string-end))) - (or (string-match re simple-name) - (error "Unexpected error in defining guix buffer name")) - (let ((first* (match-string 1 simple-name)) - (name-body (match-string 2 simple-name)) - (last* (match-string 3 simple-name))) - ;; Handle the case when buffer name is wrapped by '*'. - (if (and (string= "*" first*) - (string= "*" last*)) - (concat "*" name-body ": " profile-name "*") - (concat simple-name ": " profile-name))))) - -(defun guix-buffer-name (profile buffer-type entry-type search-type) - "Return name of a buffer used for displaying information. -See `guix-buffer-name-function' for details." - (let ((fun (if (functionp guix-buffer-name-function) - guix-buffer-name-function - #'guix-buffer-name-default))) - (funcall fun profile buffer-type entry-type search-type))) - -(defun guix-switch-to-buffer (buffer) - "Switch to a 'list' or 'info' BUFFER." - (pop-to-buffer buffer - '((display-buffer-reuse-window - display-buffer-same-window)))) - -(defun guix-buffer-p (&optional buffer modes) - "Return non-nil if BUFFER mode is derived from any of the MODES. -If BUFFER is nil, check current buffer. -If MODES is nil, use `guix-list-mode' and `guix-info-mode'." - (with-current-buffer (or buffer (current-buffer)) - (apply #'derived-mode-p - (or modes - '(guix-list-mode guix-info-mode))))) - -(defun guix-buffers (&optional modes) - "Return list of all buffers with major modes derived from MODES. -If MODES is nil, return list of all Guix 'list' and 'info' buffers." - (cl-remove-if-not (lambda (buf) - (guix-buffer-p buf modes)) - (buffer-list))) - -(defun guix-update-buffer (buffer) - "Update information in a 'list' or 'info' BUFFER." - (with-current-buffer buffer - (guix-revert-buffer nil t))) - -(defun guix-update-buffers-maybe-after-operation () - "Update buffers after Guix operation if needed. -See `guix-update-after-operation' for details." - (let ((to-update - (and guix-operation-buffer - (cl-case guix-update-after-operation - (current (and (buffer-live-p guix-operation-buffer) - (guix-buffer-p guix-operation-buffer) - (list guix-operation-buffer))) - (all (guix-buffers)))))) - (setq guix-operation-buffer nil) - (mapc #'guix-update-buffer to-update))) - -(add-hook 'guix-after-repl-operation-hook - 'guix-update-buffers-maybe-after-operation) - - -;;; Common definitions for buffer types - -(defvar guix-root-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "l") 'guix-history-back) - (define-key map (kbd "r") 'guix-history-forward) - (define-key map (kbd "g") 'revert-buffer) - (define-key map (kbd "R") 'guix-redisplay-buffer) - (define-key map (kbd "M") 'guix-apply-manifest) - (define-key map (kbd "C-c C-z") 'guix-switch-to-repl) - map) - "Parent keymap for all guix modes.") - -(defvar-local guix-profile nil - "Profile used for the current buffer.") -(put 'guix-profile 'permanent-local t) - -(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-buffer-type nil - "Type of the current buffer.") -(put 'guix-buffer-type 'permanent-local t) - -(defvar-local guix-entry-type nil - "Type of the current entry.") -(put 'guix-entry-type '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 (profile entries buffer-type entry-type - search-type search-vals) - "Set local variables for the current Guix buffer." - (setq default-directory profile - guix-profile profile - guix-entries entries - guix-buffer-type buffer-type - guix-entry-type entry-type - guix-search-type search-type - guix-search-vals search-vals)) - -(defun guix-get-symbol (postfix buffer-type &optional entry-type) - (intern (concat "guix-" - (when entry-type - (concat (symbol-name entry-type) "-")) - (symbol-name buffer-type) "-" postfix))) - -(defmacro guix-define-buffer-type (buf-type entry-type &rest args) - "Define common for BUF-TYPE buffers for displaying ENTRY-TYPE entries. - -In the text below TYPE means ENTRY-TYPE-BUF-TYPE. - -This macro defines `guix-TYPE-mode', a custom group and several -user variables. - -The following stuff should be defined outside this macro: - - - `guix-BUF-TYPE-mode' - parent mode for the defined mode. - - - `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: - - - `:buffer-name' - default value for the defined - `guix-TYPE-buffer-name' variable. - - - `: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)) - (faces-group (intern (concat prefix "-faces"))) - (mode-map-str (concat prefix "-mode-map")) - (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"))) - (history-var (intern (concat prefix "-history-size"))) - (params-var (intern (concat prefix "-required-params"))) - (buf-name-val (format "*Guix %s %s*" Entry-type-str Buf-type-str)) - (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))) - (`:buffer-name (setq buf-name-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))) - - (defgroup ,faces-group nil - ,(concat "Faces for " buf-type-str " buffer with " entry-str ".") - :group ',(intern (concat "guix-" buf-type-str "-faces"))) - - (defcustom ,buf-name-var ,buf-name-val - ,(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 'guix-revert-buffer) - (setq-local guix-history-size ,history-var) - (and (fboundp ',mode-init-fun) (,mode-init-fun)))))) - -(put 'guix-define-buffer-type 'lisp-indent-function 'defun) - - -;;; Getting and displaying info about packages and generations - -(defcustom guix-package-list-type 'output - "Define how to display packages in a list buffer. -May be a symbol `package' or `output' (if `output', display each -output on a separate line; if `package', display each package on -a separate line)." - :type '(choice (const :tag "List of packages" package) - (const :tag "List of outputs" output)) - :group 'guix) - -(defcustom guix-package-info-type 'package - "Define how to display packages in an info buffer. -May be a symbol `package' or `output' (if `output', display each -output separately; if `package', display outputs inside a package -information)." - :type '(choice (const :tag "Display packages" package) - (const :tag "Display outputs" output)) - :group 'guix) - -(defun guix-get-entries (profile 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', -`output' or `generation'. - -SEARCH-TYPE may be one of the following symbols: - -- If ENTRY-TYPE is `package' or `output': `id', `name', `regexp', - `all-available', `newest-available', `installed', `obsolete', - `generation'. - -- If ENTRY-TYPE is `generation': `id', `last', `all', `time'. - -PARAMS is a list of parameters for receiving. If nil, get -information with all available parameters." - (guix-eval-read (guix-make-guile-expression - 'entries - profile params entry-type search-type search-vals))) - -(defun guix-get-show-entries (profile buffer-type entry-type search-type - &rest search-vals) - "Search for ENTRY-TYPE entries and show results in BUFFER-TYPE buffer. -See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS." - (let ((entries (guix-get-entries profile entry-type search-type search-vals - (guix-get-params-for-receiving - buffer-type entry-type)))) - (guix-set-buffer profile entries buffer-type entry-type - search-type search-vals))) - -(defun guix-set-buffer (profile entries buffer-type entry-type search-type - search-vals &optional history-replace no-display) - "Set up BUFFER-TYPE buffer for displaying ENTRY-TYPE ENTRIES. - -Insert ENTRIES in buffer, set variables and make history item. -ENTRIES should have a form of `guix-entries'. - -See `guix-get-entries' for the meaning of SEARCH-TYPE and SEARCH-VALS. - -If HISTORY-REPLACE is non-nil, replace current history item, -otherwise add the new one. - -If NO-DISPLAY is non-nil, do not switch to the buffer." - (when entries - (let ((buf (if (and (eq major-mode - (guix-get-symbol "mode" buffer-type entry-type)) - (equal guix-profile profile)) - (current-buffer) - (get-buffer-create - (guix-buffer-name profile buffer-type - entry-type search-type))))) - (with-current-buffer buf - (guix-show-entries entries buffer-type entry-type) - (guix-set-vars profile entries buffer-type entry-type - search-type search-vals) - (funcall (if history-replace - #'guix-history-replace - #'guix-history-add) - (guix-make-history-item))) - (or no-display - (guix-switch-to-buffer buf)))) - (guix-result-message profile entries entry-type - search-type search-vals)) - -(defun guix-show-entries (entries buffer-type entry-type) - "Display ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." - (let ((inhibit-read-only t)) - (erase-buffer) - (funcall (symbol-function (guix-get-symbol - "mode" buffer-type entry-type))) - (funcall (guix-get-symbol "insert-entries" buffer-type) - entries entry-type) - (goto-char (point-min)))) - -(defun guix-history-call (profile entries buffer-type entry-type - search-type search-vals) - "Function called for moving by history." - (guix-show-entries entries buffer-type entry-type) - (guix-set-vars profile entries buffer-type entry-type - search-type search-vals) - (guix-result-message profile entries entry-type - search-type search-vals)) - -(defun guix-make-history-item () - "Make and return a history item for the current buffer." - (list #'guix-history-call - guix-profile guix-entries guix-buffer-type guix-entry-type - guix-search-type guix-search-vals)) - -(defun guix-get-params-for-receiving (buffer-type entry-type) - "Return parameters that should be received for BUFFER-TYPE, ENTRY-TYPE." - (let* ((required-var (guix-get-symbol "required-params" - buffer-type entry-type)) - (required (symbol-value required-var))) - (unless (equal required 'all) - (cl-union required - (funcall (guix-get-symbol "get-displayed-params" - buffer-type) - entry-type))))) - -(defun guix-revert-buffer (_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 noconfirm - (symbol-value - (guix-get-symbol "revert-no-confirm" - guix-buffer-type guix-entry-type)) - (y-or-n-p "Update current information? ")) - (let* ((search-type guix-search-type) - (search-vals guix-search-vals) - (params (guix-get-params-for-receiving guix-buffer-type - guix-entry-type)) - (entries (guix-get-entries - guix-profile guix-entry-type - guix-search-type guix-search-vals params)) - ;; If a REPL was restarted, package/output IDs are not actual - ;; anymore, because 'object-address'-es died with the REPL, so if a - ;; search by ID didn't give results, search again by name. - (entries (if (and (null entries) - (eq guix-search-type 'id) - (or (eq guix-entry-type 'package) - (eq guix-entry-type 'output))) - (progn - (setq search-type 'name - search-vals (guix-entries-to-specifications - guix-entries)) - (guix-get-entries - guix-profile guix-entry-type - search-type search-vals params)) - entries))) - (guix-set-buffer guix-profile entries guix-buffer-type guix-entry-type - search-type search-vals t t)))) - -(cl-defun guix-redisplay-buffer (&key buffer profile entries buffer-type - entry-type search-type search-vals) - "Redisplay a Guix BUFFER. -Restore the point and window positions after redisplaying if possible. - -This function will not update the information, use -\"\\[revert-buffer]\" if you want the full update. - -If BUFFER is nil, use the current buffer. For the meaning of the -rest arguments, see `guix-set-buffer'." - (interactive) - (or buffer (setq buffer (current-buffer))) - (with-current-buffer buffer - (or (derived-mode-p 'guix-info-mode 'guix-list-mode) - (error "%S is not a Guix buffer" buffer)) - (let* ((point (point)) - (was-at-button (button-at point)) - ;; For simplicity, ignore an unlikely case when multiple - ;; windows display the same BUFFER. - (window (car (get-buffer-window-list buffer nil t))) - (window-start (and window (window-start window)))) - (guix-set-buffer (or profile guix-profile) - (or entries guix-entries) - (or buffer-type guix-buffer-type) - (or entry-type guix-entry-type) - (or search-type guix-search-type) - (or search-vals guix-search-vals) - t t) - (goto-char point) - (and was-at-button - (not (button-at (point))) - (forward-button 1)) - (when window - (set-window-point window (point)) - (set-window-start window window-start))))) - - -;;; Generations - -(defcustom guix-generation-packages-buffer-name-function - #'guix-generation-packages-buffer-name-default - "Function used to define name of a buffer with generation packages. -This function is called with 2 arguments: PROFILE (string) and -GENERATION (number)." - :type '(choice (function-item guix-generation-packages-buffer-name-default) - (function-item guix-generation-packages-buffer-name-long) - (function :tag "Other function")) - :group 'guix) - -(defcustom guix-generation-packages-update-buffer t - "If non-nil, always update list of packages during comparing generations. -If nil, generation packages are received only once. So when you -compare generation 1 and generation 2, the packages for both -generations will be received. Then if you compare generation 1 -and generation 3, only the packages for generation 3 will be -received. Thus if you use comparing of different generations a -lot, you may set this variable to nil to improve the -performance." - :type 'boolean - :group 'guix) - -(defvar guix-output-name-width 30 - "Width of an output name \"column\". -This variable is used in auxiliary buffers for comparing generations.") - (defun guix-generation-file (profile generation) "Return the file name of a PROFILE's GENERATION." (format "%s-%s-link" profile generation)) @@ -724,74 +100,14 @@ this generation." (guix-generation-file profile generation) profile))) -(defun guix-generation-packages (profile generation) - "Return a list of sorted packages installed in PROFILE's GENERATION. -Each element of the list is a list of the package specification and its path." - (let ((names+paths (guix-eval-read - (guix-make-guile-expression - 'generation-package-specifications+paths - profile generation)))) - (sort names+paths - (lambda (a b) - (string< (car a) (car b)))))) - -(defun guix-generation-packages-buffer-name-default (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use base name of PROFILE path." - (let ((profile-name (file-name-base (directory-file-name profile)))) - (format "*Guix %s: generation %s*" - profile-name generation))) - -(defun guix-generation-packages-buffer-name-long (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs. -Use the full PROFILE path." - (format "*Guix generation %s (%s)*" - generation profile)) - -(defun guix-generation-packages-buffer-name (profile generation) - "Return name of a buffer for displaying GENERATION's package outputs." - (let ((fun (if (functionp guix-generation-packages-buffer-name-function) - guix-generation-packages-buffer-name-function - #'guix-generation-packages-buffer-name-default))) - (funcall fun profile generation))) - -(defun guix-generation-insert-package (name path) - "Insert package output NAME and PATH at point." - (insert name) - (indent-to guix-output-name-width 2) - (insert path "\n")) - -(defun guix-generation-insert-packages (buffer profile generation) - "Insert package outputs installed in PROFILE's GENERATION in BUFFER." - (with-current-buffer buffer - (setq buffer-read-only nil - indent-tabs-mode nil) - (erase-buffer) - (mapc (lambda (name+path) - (guix-generation-insert-package - (car name+path) (cadr name+path))) - (guix-generation-packages profile generation)))) - -(defun guix-generation-packages-buffer (profile generation) - "Return buffer with package outputs installed in PROFILE's GENERATION. -Create the buffer if needed." - (let ((buf-name (guix-generation-packages-buffer-name - profile generation))) - (or (and (null guix-generation-packages-update-buffer) - (get-buffer buf-name)) - (let ((buf (get-buffer-create buf-name))) - (guix-generation-insert-packages buf profile generation) - buf)))) - -(defun guix-profile-generation-manifest-file (generation) - "Return the file name of a GENERATION's manifest. -GENERATION is a generation number of `guix-profile' profile." - (guix-manifest-file guix-profile generation)) - -(defun guix-profile-generation-packages-buffer (generation) - "Insert GENERATION's package outputs in a buffer and return it. -GENERATION is a generation number of `guix-profile' profile." - (guix-generation-packages-buffer guix-profile generation)) +;;;###autoload +(defun guix-edit (id-or-name) + "Edit (go to location of) package with ID-OR-NAME." + (interactive (list (guix-read-package-name))) + (let ((loc (guix-package-location id-or-name))) + (if loc + (guix-find-location loc) + (message "Couldn't find package location.")))) ;;; Actions on packages and generations @@ -865,101 +181,6 @@ VARIABLE is a name of an option variable.") guix-operation-option-true-string guix-operation-option-false-string)) -(defun guix-process-package-actions (profile actions - &optional operation-buffer) - "Process package ACTIONS on PROFILE. -Each action is a list of the form: - - (ACTION-TYPE PACKAGE-SPEC ...) - -ACTION-TYPE is one of the following symbols: `install', -`upgrade', `remove'/`delete'. -PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." - (let (install upgrade remove) - (mapc (lambda (action) - (let ((action-type (car action)) - (specs (cdr action))) - (cl-case action-type - (install (setq install (append install specs))) - (upgrade (setq upgrade (append upgrade specs))) - ((remove delete) (setq remove (append remove specs)))))) - actions) - (when (guix-continue-package-operation-p - profile - :install install :upgrade upgrade :remove remove) - (guix-eval-in-repl - (guix-make-guile-expression - 'process-package-actions profile - :install install :upgrade upgrade :remove remove - :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)) - (and (not guix-dry-run) operation-buffer))))) - -(cl-defun guix-continue-package-operation-p (profile - &key install upgrade remove) - "Return non-nil if a package operation should be continued. -Ask a user if needed (see `guix-operation-confirm'). -INSTALL, UPGRADE, REMOVE are 'package action specifications'. -See `guix-process-package-actions' for details." - (or (null guix-operation-confirm) - (let* ((entries (guix-get-entries - profile 'package 'id - (append (mapcar #'car install) - (mapcar #'car upgrade) - (mapcar #'car remove)) - '(id name version location))) - (install-strings (guix-get-package-strings install entries)) - (upgrade-strings (guix-get-package-strings upgrade entries)) - (remove-strings (guix-get-package-strings remove entries))) - (if (or install-strings upgrade-strings remove-strings) - (let ((buf (get-buffer-create guix-temp-buffer-name))) - (with-current-buffer buf - (setq-local cursor-type nil) - (setq buffer-read-only nil) - (erase-buffer) - (insert "Profile: " profile "\n\n") - (guix-insert-package-strings install-strings "install") - (guix-insert-package-strings upgrade-strings "upgrade") - (guix-insert-package-strings remove-strings "remove") - (let ((win (temp-buffer-window-show - buf - '((display-buffer-reuse-window - display-buffer-at-bottom) - (window-height . fit-window-to-buffer))))) - (prog1 (guix-operation-prompt) - (quit-window nil win))))) - (message "Nothing to be done. If 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-assq-value entry 'location))) - (concat (guix-get-full-name entry) - (when outputs - (concat ":" - (guix-concat-strings outputs ","))) - (when location - (concat "\t(" location ")"))))))) - specs))) - -(defun guix-insert-package-strings (strings action) - "Insert information STRINGS at point for performing package ACTION." - (when strings - (insert "Package(s) to " (propertize action 'face 'bold) ":\n") - (mapc (lambda (str) - (insert " " str "\n")) - strings) - (insert "\n"))) - (defun guix-operation-prompt (&optional prompt) "Prompt a user for continuing the current operation. Return non-nil, if the operation should be continued; nil otherwise. @@ -1014,34 +235,6 @@ Ask a user with PROMPT for continuing an operation." guix-operation-option-separator))) (force-mode-line-update)) -(defun guix-delete-generations (profile generations - &optional operation-buffer) - "Delete GENERATIONS from PROFILE. -Each element from GENERATIONS is a generation number." - (when (or (not guix-operation-confirm) - (y-or-n-p - (let ((count (length generations))) - (if (> count 1) - (format "Delete %d generations from profile '%s'? " - count profile) - (format "Delete generation %d from profile '%s'? " - (car generations) profile))))) - (guix-eval-in-repl - (guix-make-guile-expression - 'delete-generations* profile generations) - operation-buffer))) - -(defun guix-switch-to-generation (profile generation - &optional operation-buffer) - "Switch PROFILE to GENERATION." - (when (or (not guix-operation-confirm) - (y-or-n-p (format "Switch profile '%s' to generation %d? " - profile generation))) - (guix-eval-in-repl - (guix-make-guile-expression - 'switch-to-generation* profile generation) - operation-buffer))) - (defun guix-package-source-path (package-id) "Return a store file path to a source of a package PACKAGE-ID." (message "Calculating the source derivation ...") @@ -1075,12 +268,12 @@ See Info node `(guix) Invoking guix package' for details. Interactively, use the current profile and prompt for manifest FILE. With a prefix argument, also prompt for PROFILE." (interactive - (let* ((default-profile (or guix-profile guix-current-profile)) + (let* ((current-profile (guix-ui-current-profile)) (profile (if current-prefix-arg (guix-profile-prompt) - default-profile)) + (or current-profile guix-current-profile))) (file (read-file-name "File with manifest: ")) - (buffer (and guix-profile (current-buffer)))) + (buffer (and current-profile (current-buffer)))) (list profile file buffer))) (when (or (not guix-operation-confirm) (y-or-n-p (format "Apply manifest from '%s' to profile '%s'? " @@ -1174,12 +367,12 @@ The function is called with a single argument - a command line string." (defun guix-update-buffers-maybe-after-pull () "Update buffers depending on `guix-update-after-pull'." (when guix-update-after-pull - (mapc #'guix-update-buffer + (mapc #'guix-ui-update-buffer ;; No need to update "generation" buffers. - (guix-buffers '(guix-package-list-mode - guix-package-info-mode - guix-output-list-mode - guix-output-info-mode))) + (guix-ui-buffers '(guix-package-list-mode + guix-package-info-mode + guix-output-list-mode + guix-output-info-mode))) (message "Guix buffers have been updated."))) ;;;###autoload diff --git a/emacs/guix-buffer.el b/emacs/guix-buffer.el new file mode 100644 index 0000000000..af76e638b6 --- /dev/null +++ b/emacs/guix-buffer.el @@ -0,0 +1,622 @@ +;;; guix-buffer.el --- Buffer interface for displaying data -*- lexical-binding: t -*- + +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides a general 'buffer' interface for displaying an +;; arbitrary data. + +;;; Code: + +(require 'cl-lib) +(require 'guix-history) +(require 'guix-utils) + +(defvar guix-buffer-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "l") 'guix-history-back) + (define-key map (kbd "r") 'guix-history-forward) + (define-key map (kbd "g") 'revert-buffer) + (define-key map (kbd "R") 'guix-buffer-redisplay) + map) + "Parent keymap for Guix buffer modes.") + + +;;; Buffer item + +(cl-defstruct (guix-buffer-item + (:constructor nil) + (:constructor guix-buffer-make-item + (entries buffer-type entry-type args)) + (:copier nil)) + entries buffer-type entry-type args) + +(defvar-local guix-buffer-item nil + "Data (structure) for the current Guix buffer. +The structure consists of the following elements: + +- `entries': list of the currently displayed entries. + + Each element of the list is an alist with an entry data of the + following form: + + ((PARAM . VAL) ...) + + PARAM is a name of the entry parameter. + VAL is a value of this parameter. + +- `entry-type': type of the currently displayed entries. + +- `buffer-type': type of the current buffer. + +- `args': search arguments used to get the current entries.") +(put 'guix-buffer-item 'permanent-local t) + +(defmacro guix-buffer-with-item (item &rest body) + "Evaluate BODY using buffer ITEM. +The following local variables are available inside BODY: +`%entries', `%buffer-type', `%entry-type', `%args'. +See `guix-buffer-item' for details." + (declare (indent 1) (debug t)) + (let ((item-var (make-symbol "item"))) + `(let ((,item-var ,item)) + (let ((%entries (guix-buffer-item-entries ,item-var)) + (%buffer-type (guix-buffer-item-buffer-type ,item-var)) + (%entry-type (guix-buffer-item-entry-type ,item-var)) + (%args (guix-buffer-item-args ,item-var))) + ,@body)))) + +(defmacro guix-buffer-with-current-item (&rest body) + "Evaluate BODY using `guix-buffer-item'. +See `guix-buffer-with-item' for details." + (declare (indent 0) (debug t)) + `(guix-buffer-with-item guix-buffer-item + ,@body)) + +(defmacro guix-buffer-define-current-item-accessor (name) + "Define `guix-buffer-current-NAME' function to access NAME +element of `guix-buffer-item' structure. +NAME should be a symbol." + (let* ((name-str (symbol-name name)) + (accessor (intern (concat "guix-buffer-item-" name-str))) + (fun-name (intern (concat "guix-buffer-current-" name-str))) + (doc (format "\ +Return '%s' of the current Guix buffer. +See `guix-buffer-item' for details." + name-str))) + `(defun ,fun-name () + ,doc + (and guix-buffer-item + (,accessor guix-buffer-item))))) + +(defmacro guix-buffer-define-current-item-accessors (&rest names) + "Define `guix-buffer-current-NAME' functions for NAMES. +See `guix-buffer-define-current-item-accessor' for details." + `(progn + ,@(mapcar (lambda (name) + `(guix-buffer-define-current-item-accessor ,name)) + names))) + +(guix-buffer-define-current-item-accessors + entries entry-type buffer-type args) + +(defmacro guix-buffer-define-current-args-accessor (n prefix name) + "Define `PREFIX-NAME' function to access Nth element of 'args' +field of `guix-buffer-item' structure. +PREFIX and NAME should be strings." + (let ((fun-name (intern (concat prefix "-" name))) + (doc (format "\ +Return '%s' of the current Guix buffer. +'%s' is the element number %d in 'args' of `guix-buffer-item'." + name name n))) + `(defun ,fun-name () + ,doc + (nth ,n (guix-buffer-current-args))))) + +(defmacro guix-buffer-define-current-args-accessors (prefix &rest names) + "Define `PREFIX-NAME' functions for NAMES. +See `guix-buffer-define-current-args-accessor' for details." + `(progn + ,@(cl-loop for name in names + for i from 0 + collect `(guix-buffer-define-current-args-accessor + ,i ,prefix ,name)))) + + +;;; Wrappers for defined variables + +(defvar guix-buffer-data nil + "Alist with 'buffer' data. +This alist is filled by `guix-buffer-define-interface' macro.") + +(defun guix-buffer-value (buffer-type entry-type symbol) + "Return SYMBOL's value for BUFFER-TYPE/ENTRY-TYPE from `guix-buffer-data'." + (symbol-value + (guix-assq-value guix-buffer-data buffer-type entry-type symbol))) + +(defun guix-buffer-get-entries (buffer-type entry-type args) + "Return ENTRY-TYPE entries. +Call an appropriate 'get-entries' function from `guix-buffer' +using ARGS as its arguments." + (apply (guix-buffer-value buffer-type entry-type 'get-entries) + args)) + +(defun guix-buffer-mode-enable (buffer-type entry-type) + "Turn on major mode to display ENTRY-TYPE ENTRIES in BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'mode))) + +(defun guix-buffer-mode-initialize (buffer-type entry-type) + "Set up the current BUFFER-TYPE buffer to display ENTRY-TYPE entries." + (let ((fun (guix-buffer-value buffer-type entry-type 'mode-init))) + (when fun + (funcall fun)))) + +(defun guix-buffer-insert-entries (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'insert-entries) + entries)) + +(defun guix-buffer-show-entries-default (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (let ((inhibit-read-only t)) + (erase-buffer) + (guix-buffer-mode-enable buffer-type entry-type) + (guix-buffer-insert-entries entries buffer-type entry-type) + (goto-char (point-min)))) + +(defun guix-buffer-show-entries (entries buffer-type entry-type) + "Show ENTRY-TYPE ENTRIES in the current BUFFER-TYPE buffer." + (funcall (guix-buffer-value buffer-type entry-type 'show-entries) + entries)) + +(defun guix-buffer-message (entries buffer-type entry-type args) + "Display a message for BUFFER-ITEM after showing entries." + (let ((fun (guix-buffer-value buffer-type entry-type 'message))) + (when fun + (apply fun entries args)))) + +(defun guix-buffer-name (buffer-type entry-type args) + "Return name of BUFFER-TYPE buffer for displaying ENTRY-TYPE entries." + (let ((str-or-fun (guix-buffer-value buffer-type entry-type + 'buffer-name))) + (if (stringp str-or-fun) + str-or-fun + (apply str-or-fun args)))) + +(defun guix-buffer-param-title (buffer-type entry-type param) + "Return PARAM title for BUFFER-TYPE/ENTRY-TYPE." + (or (guix-assq-value (guix-buffer-value buffer-type entry-type 'titles) + param) + ;; Fallback to a title defined in 'info' interface. + (unless (eq buffer-type 'info) + (guix-assq-value (guix-buffer-value 'info entry-type 'titles) + param)) + (guix-symbol-title param))) + +(defun guix-buffer-history-size (buffer-type entry-type) + "Return history size for BUFFER-TYPE/ENTRY-TYPE." + (guix-buffer-value buffer-type entry-type 'history-size)) + +(defun guix-buffer-revert-confirm? (buffer-type entry-type) + "Return 'revert-confirm' value for BUFFER-TYPE/ENTRY-TYPE." + (guix-buffer-value buffer-type entry-type 'revert-confirm)) + + +;;; Displaying entries + +(defun guix-buffer-display (buffer) + "Switch to a Guix BUFFER." + (pop-to-buffer buffer + '((display-buffer-reuse-window + display-buffer-same-window)))) + +(defun guix-buffer-history-item (buffer-item) + "Make and return a history item for displaying BUFFER-ITEM." + (list #'guix-buffer-set buffer-item)) + +(defun guix-buffer-set (buffer-item &optional history) + "Set up the current buffer for displaying BUFFER-ITEM. +HISTORY should be one of the following: + + `nil' - do not save BUFFER-ITEM in history, + + `add' - add it to history, + + `replace' - replace the current history item." + (guix-buffer-with-item buffer-item + (when %entries + (guix-buffer-show-entries %entries %buffer-type %entry-type) + (setq guix-buffer-item buffer-item) + (when history + (funcall (cl-ecase history + (add #'guix-history-add) + (replace #'guix-history-replace)) + (guix-buffer-history-item buffer-item)))) + (guix-buffer-message %entries %buffer-type %entry-type %args))) + +(defun guix-buffer-display-entries-current + (entries buffer-type entry-type args &optional history) + "Show ENTRIES in the current Guix buffer. +See `guix-buffer-item' for the meaning of BUFFER-TYPE, ENTRY-TYPE +and ARGS, and `guix-buffer-set' for the meaning of HISTORY." + (let ((item (guix-buffer-make-item entries buffer-type + entry-type args))) + (guix-buffer-set item history))) + +(defun guix-buffer-get-display-entries-current + (buffer-type entry-type args &optional history) + "Search for entries and show them in the current Guix buffer. +See `guix-buffer-display-entries-current' for details." + (guix-buffer-display-entries-current + (guix-buffer-get-entries buffer-type entry-type args) + buffer-type entry-type args history)) + +(defun guix-buffer-display-entries + (entries buffer-type entry-type args &optional history) + "Show ENTRIES in a BUFFER-TYPE buffer. +See `guix-buffer-display-entries-current' for details." + (let ((buffer (get-buffer-create + (guix-buffer-name buffer-type entry-type args)))) + (with-current-buffer buffer + (guix-buffer-display-entries-current + entries buffer-type entry-type args history)) + (when entries + (guix-buffer-display buffer)))) + +(defun guix-buffer-get-display-entries + (buffer-type entry-type args &optional history) + "Search for entries and show them in a BUFFER-TYPE buffer. +See `guix-buffer-display-entries-current' for details." + (guix-buffer-display-entries + (guix-buffer-get-entries buffer-type entry-type args) + buffer-type entry-type args history)) + +(defun guix-buffer-revert (_ignore-auto noconfirm) + "Update the data in the current Guix buffer. +This function is suitable for `revert-buffer-function'. +See `revert-buffer' for the meaning of NOCONFIRM." + (guix-buffer-with-current-item + (when (or noconfirm + (not (guix-buffer-revert-confirm? %buffer-type %entry-type)) + (y-or-n-p "Update the current buffer? ")) + (guix-buffer-get-display-entries-current + %buffer-type %entry-type %args 'replace)))) + +(defvar guix-buffer-after-redisplay-hook nil + "Hook run by `guix-buffer-redisplay'. +This hook is called before seting up a window position.") + +(defun guix-buffer-redisplay () + "Redisplay the current Guix buffer. +Restore the point and window positions after redisplaying. + +This function does not update the buffer data, use +'\\[revert-buffer]' if you want the full update." + (interactive) + (let* ((old-point (point)) + ;; For simplicity, ignore an unlikely case when multiple + ;; windows display the same buffer. + (window (car (get-buffer-window-list (current-buffer) nil t))) + (window-start (and window (window-start window)))) + (guix-buffer-set guix-buffer-item) + (goto-char old-point) + (run-hooks 'guix-buffer-after-redisplay-hook) + (when window + (set-window-point window (point)) + (set-window-start window window-start)))) + +(defun guix-buffer-redisplay-goto-button () + "Redisplay the current buffer and go to the next button, if needed." + (let ((guix-buffer-after-redisplay-hook + (cons (lambda () + (unless (button-at (point)) + (forward-button 1))) + guix-buffer-after-redisplay-hook))) + (guix-buffer-redisplay))) + + +;;; Interface definers + +(defmacro guix-define-groups (type &rest args) + "Define `guix-TYPE' and `guix-TYPE-faces' custom groups. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Optional keywords: + + - `:parent-group' - name of a parent custom group. + + - `:parent-faces-group' - name of a parent custom faces group. + + - `:group-doc' - docstring of a `guix-TYPE' group. + + - `:faces-group-doc' - docstring of a `guix-TYPE-faces' group." + (declare (indent 1)) + (let* ((type-str (symbol-name type)) + (prefix (concat "guix-" type-str)) + (group (intern prefix)) + (faces-group (intern (concat prefix "-faces")))) + (guix-keyword-args-let args + ((parent-group :parent-group 'guix) + (parent-faces-group :parent-faces-group 'guix-faces) + (group-doc :group-doc + (format "Settings for '%s' buffers." + type-str)) + (faces-group-doc :faces-group-doc + (format "Faces for '%s' buffers." + type-str))) + `(progn + (defgroup ,group nil + ,group-doc + :group ',parent-group) + + (defgroup ,faces-group nil + ,faces-group-doc + :group ',group + :group ',parent-faces-group))))) + +(defmacro guix-define-entry-type (entry-type &rest args) + "Define general code for ENTRY-TYPE. +See `guix-define-groups'." + (declare (indent 1)) + `(guix-define-groups ,entry-type + ,@args)) + +(defmacro guix-define-buffer-type (buffer-type &rest args) + "Define general code for BUFFER-TYPE. +See `guix-define-groups'." + (declare (indent 1)) + `(guix-define-groups ,buffer-type + ,@args)) + +(defmacro guix-buffer-define-interface (buffer-type entry-type &rest args) + "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... +In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. + +Required keywords: + + - `:buffer-name' - default value of the generated + `guix-TYPE-buffer-name' variable. + + - `:get-entries-function' - default value of the generated + `guix-TYPE-get-function' variable. + + - `:show-entries-function' - default value of the generated + `guix-TYPE-show-function' variable. + + Alternatively, if `:show-entries-function' is not specified, a + default `guix-TYPE-show-entries' will be generated, and the + following keyword should be specified instead: + + - `:insert-entries-function' - default value of the generated + `guix-TYPE-insert-function' variable. + +Optional keywords: + + - `:message-function' - default value of the generated + `guix-TYPE-message-function' variable. + + - `:titles' - default value of the generated + `guix-TYPE-titles' variable. + + - `:history-size' - default value of the generated + `guix-TYPE-history-size' variable. + + - `:revert-confirm?' - default value of the generated + `guix-TYPE-revert-confirm' variable. + + - `:mode-name' - name (a string appeared in the mode-line) of + the generated `guix-TYPE-mode'. + + - `:mode-init-function' - default value of the generated + `guix-TYPE-mode-initialize-function' variable. + + - `:reduced?' - if non-nil, generate only group, faces group + and titles variable (if specified); all keywords become + optional." + (declare (indent 2)) + (let* ((entry-type-str (symbol-name entry-type)) + (buffer-type-str (symbol-name buffer-type)) + (prefix (concat "guix-" entry-type-str "-" + buffer-type-str)) + (group (intern prefix)) + (faces-group (intern (concat prefix "-faces"))) + (get-entries-var (intern (concat prefix "-get-function"))) + (show-entries-var (intern (concat prefix "-show-function"))) + (show-entries-fun (intern (concat prefix "-show-entries"))) + (message-var (intern (concat prefix "-message-function"))) + (buffer-name-var (intern (concat prefix "-buffer-name"))) + (titles-var (intern (concat prefix "-titles"))) + (history-size-var (intern (concat prefix "-history-size"))) + (revert-confirm-var (intern (concat prefix "-revert-confirm")))) + (guix-keyword-args-let args + ((get-entries-val :get-entries-function) + (show-entries-val :show-entries-function) + (insert-entries-val :insert-entries-function) + (mode-name :mode-name (capitalize prefix)) + (mode-init-val :mode-init-function) + (message-val :message-function) + (buffer-name-val :buffer-name) + (titles-val :titles) + (history-size-val :history-size 20) + (revert-confirm-val :revert-confirm? t) + (reduced? :reduced?)) + `(progn + (defgroup ,group nil + ,(format "Displaying '%s' entries in '%s' buffer." + entry-type-str buffer-type-str) + :group ',(intern (concat "guix-" entry-type-str)) + :group ',(intern (concat "guix-" buffer-type-str))) + + (defgroup ,faces-group nil + ,(format "Faces for displaying '%s' entries in '%s' buffer." + entry-type-str buffer-type-str) + :group ',group + :group ',(intern (concat "guix-" entry-type-str "-faces")) + :group ',(intern (concat "guix-" buffer-type-str "-faces"))) + + (defcustom ,titles-var ,titles-val + ,(format "Alist of titles of '%s' parameters." + entry-type-str) + :type '(alist :key-type symbol :value-type string) + :group ',group) + + ,(unless reduced? + `(progn + (defvar ,get-entries-var ,get-entries-val + ,(format "\ +Function used to receive '%s' entries for '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,show-entries-var + ,(or show-entries-val `',show-entries-fun) + ,(format "\ +Function used to show '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,message-var ,message-val + ,(format "\ +Function used to display a message after showing '%s' entries. +If nil, do not display messages." + entry-type-str)) + + (defcustom ,buffer-name-var ,buffer-name-val + ,(format "\ +Default name of '%s' buffer for displaying '%s' entries. +May be a string or a function returning a string. The function +is called with the same arguments as `%S'." + buffer-type-str entry-type-str get-entries-var) + :type '(choice string function) + :group ',group) + + (defcustom ,history-size-var ,history-size-val + ,(format "\ +Maximum number of items saved in history of `%S' buffer. +If 0, the history is disabled." + buffer-name-var) + :type 'integer + :group ',group) + + (defcustom ,revert-confirm-var ,revert-confirm-val + ,(format "\ +If non-nil, ask to confirm for reverting `%S' buffer." + buffer-name-var) + :type 'boolean + :group ',group) + + (guix-alist-put! + '((get-entries . ,get-entries-var) + (show-entries . ,show-entries-var) + (message . ,message-var) + (buffer-name . ,buffer-name-var) + (history-size . ,history-size-var) + (revert-confirm . ,revert-confirm-var)) + 'guix-buffer-data ',buffer-type ',entry-type) + + ,(unless show-entries-val + `(defun ,show-entries-fun (entries) + ,(format "\ +Show '%s' ENTRIES in the current '%s' buffer." + entry-type-str buffer-type-str) + (guix-buffer-show-entries-default + entries ',buffer-type ',entry-type))) + + ,(when (or insert-entries-val + (null show-entries-val)) + (let ((insert-entries-var + (intern (concat prefix "-insert-function")))) + `(progn + (defvar ,insert-entries-var ,insert-entries-val + ,(format "\ +Function used to print '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (guix-alist-put! + ',insert-entries-var 'guix-buffer-data + ',buffer-type ',entry-type + 'insert-entries)))) + + ,(when (or mode-name + mode-init-val + (null show-entries-val)) + (let* ((mode-str (concat prefix "-mode")) + (mode-map-str (concat mode-str "-map")) + (mode (intern mode-str)) + (parent-mode (intern + (concat "guix-" buffer-type-str + "-mode"))) + (mode-var (intern + (concat mode-str "-function"))) + (mode-init-var (intern + (concat mode-str + "-initialize-function")))) + `(progn + (defvar ,mode-var ',mode + ,(format "\ +Major mode for displaying '%s' entries in '%s' buffer." + entry-type-str buffer-type-str)) + + (defvar ,mode-init-var ,mode-init-val + ,(format "\ +Function used to set up '%s' buffer for displaying '%s' entries." + buffer-type-str entry-type-str)) + + (define-derived-mode ,mode ,parent-mode ,mode-name + ,(format "\ +Major mode for displaying '%s' entries in '%s' buffer. + +\\{%s}" + entry-type-str buffer-type-str mode-map-str) + (setq-local revert-buffer-function + 'guix-buffer-revert) + (setq-local guix-history-size + (guix-buffer-history-size + ',buffer-type ',entry-type)) + (guix-buffer-mode-initialize + ',buffer-type ',entry-type)) + + (guix-alist-put! + ',mode-var 'guix-buffer-data + ',buffer-type ',entry-type 'mode) + (guix-alist-put! + ',mode-init-var 'guix-buffer-data + ',buffer-type ',entry-type + 'mode-init)))))) + + (guix-alist-put! + ',titles-var 'guix-buffer-data + ',buffer-type ',entry-type 'titles))))) + + +(defvar guix-buffer-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group (or "guix-buffer-with-item" + "guix-buffer-with-current-item" + "guix-buffer-define-interface" + "guix-define-groups" + "guix-define-entry-type" + "guix-define-buffer-type")) + symbol-end) + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode guix-buffer-font-lock-keywords) + +(provide 'guix-buffer) + +;;; guix-buffer.el ends here diff --git a/emacs/guix-command.el b/emacs/guix-command.el index ccd85d25b9..9cb7032abc 100644 --- a/emacs/guix-command.el +++ b/emacs/guix-command.el @@ -690,7 +690,7 @@ Perform pull-specific actions after operation, see open the log file(s)." (let* ((args (if (member "--log-file" args) args - (apply #'list (car args) "--log-file" (cdr args)))) + (cl-list* (car args) "--log-file" (cdr args)))) (output (guix-command-output args)) (files (split-string output "\n" t))) (dolist (file files) @@ -715,10 +715,9 @@ open the log file(s)." (map-file (or wished-map-file (guix-png-file-name))) (args (if wished-map-file args - (apply #'list - (car args) - (concat "--map-file=" map-file) - (cdr args))))) + (cl-list* (car args) + (concat "--map-file=" map-file) + (cdr args))))) (guix-command-output args) (guix-find-file map-file))) diff --git a/emacs/guix-entry.el b/emacs/guix-entry.el new file mode 100644 index 0000000000..5eed2ed015 --- /dev/null +++ b/emacs/guix-entry.el @@ -0,0 +1,59 @@ +;;; guix-entry.el --- 'Entry' type -*- lexical-binding: t -*- + +;; Copyright © 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides an API for 'entry' type which is just an alist of +;; KEY/VALUE pairs (KEY should be a symbol) with the required 'id' KEY. + +;;; Code: + +(require 'cl-lib) +(require 'guix-utils) + +(defalias 'guix-entry-value #'guix-assq-value) + +(defun guix-entry-id (entry) + "Return ENTRY ID." + (guix-entry-value entry 'id)) + +(defun guix-entry-by-id (id entries) + "Return an entry from ENTRIES by its ID." + (cl-find-if (lambda (entry) + (equal (guix-entry-id entry) id)) + entries)) + +(defun guix-entries-by-ids (ids entries) + "Return entries with IDS (a list of identifiers) from ENTRIES." + (cl-remove-if-not (lambda (entry) + (member (guix-entry-id entry) ids)) + entries)) + +(defun guix-replace-entry (id new-entry entries) + "Replace an entry with ID from ENTRIES by NEW-ENTRY. +Return a list of entries with the replaced entry." + (cl-substitute-if new-entry + (lambda (entry) + (equal id (guix-entry-id entry))) + entries + :count 1)) + +(provide 'guix-entry) + +;;; guix-entry.el ends here diff --git a/emacs/guix-external.el b/emacs/guix-external.el index c80b36343d..f571ffd845 100644 --- a/emacs/guix-external.el +++ b/emacs/guix-external.el @@ -23,6 +23,7 @@ ;;; Code: +(require 'cl-lib) (require 'guix-config) (defgroup guix-external nil @@ -67,10 +68,9 @@ If ARGS is nil, use `guix-dot-default-arguments'." (or guix-dot-program (error (concat "Couldn't find 'dot'.\n" "Set guix-dot-program to a proper value"))) - (apply #'list - guix-dot-program - (concat "-o" output-file) - (or args guix-dot-default-arguments))) + (cl-list* guix-dot-program + (concat "-o" output-file) + (or args guix-dot-default-arguments))) (defun guix-dot-file-name () "Call `guix-dot-file-name-function'." diff --git a/emacs/guix-hydra-build.el b/emacs/guix-hydra-build.el new file mode 100644 index 0000000000..232221e773 --- /dev/null +++ b/emacs/guix-hydra-build.el @@ -0,0 +1,362 @@ +;;; guix-hydra-build.el --- Interface for Hydra builds -*- lexical-binding: t -*- + +;; Copyright © 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides an interface for displaying Hydra builds in +;; 'list' and 'info' buffers. + +;;; Code: + +(require 'cl-lib) +(require 'guix-buffer) +(require 'guix-list) +(require 'guix-info) +(require 'guix-hydra) +(require 'guix-build-log) +(require 'guix-utils) + +(guix-hydra-define-entry-type hydra-build + :search-types '((latest . guix-hydra-build-latest-api-url) + (queue . guix-hydra-build-queue-api-url)) + :filters '(guix-hydra-build-filter-status) + :filter-names '((nixname . name) + (buildstatus . build-status) + (timestamp . time)) + :filter-boolean-params '(finished busy)) + +(defun guix-hydra-build-get-display (search-type &rest args) + "Search for Hydra builds and show results." + (apply #'guix-list-get-display-entries + 'hydra-build search-type args)) + +(cl-defun guix-hydra-build-latest-prompt-args (&key project jobset + job system) + "Prompt for and return a list of 'latest builds' arguments." + (let* ((number (read-number "Number of latest builds: ")) + (project (if current-prefix-arg + (guix-hydra-read-project nil project) + project)) + (jobset (if current-prefix-arg + (guix-hydra-read-jobset nil jobset) + jobset)) + (job-or-name (if current-prefix-arg + (guix-hydra-read-job nil job) + job)) + (job (and job-or-name + (string-match-p guix-hydra-job-regexp + job-or-name) + job-or-name)) + (system (if (and (not job) + (or current-prefix-arg + (and job-or-name (not system)))) + (if job-or-name + (guix-while-null + (guix-hydra-read-system + (concat job-or-name ".") system)) + (guix-hydra-read-system nil system)) + system)) + (job (or job + (and job-or-name + (concat job-or-name "." system))))) + (list number + :project project + :jobset jobset + :job job + :system system))) + +(defun guix-hydra-build-view-log (id) + "View build log of a hydra build ID." + (guix-build-log-find-file (guix-hydra-build-log-url id))) + + +;;; Defining URLs + +(defun guix-hydra-build-url (id) + "Return Hydra URL of a build ID." + (guix-hydra-url "build/" (number-to-string id))) + +(defun guix-hydra-build-log-url (id) + "Return Hydra URL of the log file of a build ID." + (concat (guix-hydra-build-url id) "/log/raw")) + +(cl-defun guix-hydra-build-latest-api-url + (number &key project jobset job system) + "Return Hydra API URL to receive latest NUMBER of builds." + (guix-hydra-api-url "latestbuilds" + `(("nr" . ,number) + ("project" . ,project) + ("jobset" . ,jobset) + ("job" . ,job) + ("system" . ,system)))) + +(defun guix-hydra-build-queue-api-url (number) + "Return Hydra API URL to receive the NUMBER of queued builds." + (guix-hydra-api-url "queue" + `(("nr" . ,number)))) + + +;;; Filters for processing raw entries + +(defun guix-hydra-build-filter-status (entry) + "Add 'status' parameter to 'hydra-build' ENTRY." + (let ((status (if (guix-entry-value entry 'finished) + (guix-hydra-build-status-number->name + (guix-entry-value entry 'build-status)) + (if (guix-entry-value entry 'busy) + 'running + 'scheduled)))) + (cons `(status . ,status) + entry))) + + +;;; Build status + +(defface guix-hydra-build-status-running + '((t :inherit bold)) + "Face used if hydra build is not finished." + :group 'guix-hydra-build-faces) + +(defface guix-hydra-build-status-scheduled + '((t)) + "Face used if hydra build is scheduled." + :group 'guix-hydra-build-faces) + +(defface guix-hydra-build-status-succeeded + '((t :inherit success)) + "Face used if hydra build succeeded." + :group 'guix-hydra-build-faces) + +(defface guix-hydra-build-status-cancelled + '((t :inherit warning)) + "Face used if hydra build was cancelled." + :group 'guix-hydra-build-faces) + +(defface guix-hydra-build-status-failed + '((t :inherit error)) + "Face used if hydra build failed." + :group 'guix-hydra-build-faces) + +(defvar guix-hydra-build-status-alist + '((0 . succeeded) + (1 . failed-build) + (2 . failed-dependency) + (3 . failed-other) + (4 . cancelled)) + "Alist of hydra build status numbers and status names. +Status numbers are returned by Hydra API, names (symbols) are +used internally by the elisp code of this package.") + +(defun guix-hydra-build-status-number->name (number) + "Convert build status number to a name. +See `guix-hydra-build-status-alist'." + (guix-assq-value guix-hydra-build-status-alist number)) + +(defun guix-hydra-build-status-string (status) + "Return a human readable string for build STATUS." + (cl-case status + (scheduled + (guix-get-string "Scheduled" 'guix-hydra-build-status-scheduled)) + (running + (guix-get-string "Running" 'guix-hydra-build-status-running)) + (succeeded + (guix-get-string "Succeeded" 'guix-hydra-build-status-succeeded)) + (cancelled + (guix-get-string "Cancelled" 'guix-hydra-build-status-cancelled)) + (failed-build + (guix-hydra-build-status-fail-string)) + (failed-dependency + (guix-hydra-build-status-fail-string "dependency")) + (failed-other + (guix-hydra-build-status-fail-string "other")))) + +(defun guix-hydra-build-status-fail-string (&optional reason) + "Return a string for a failed build." + (let ((base (guix-get-string "Failed" 'guix-hydra-build-status-failed))) + (if reason + (concat base " (" reason ")") + base))) + +(defun guix-hydra-build-finished? (entry) + "Return non-nil, if hydra build was finished." + (guix-entry-value entry 'finished)) + +(defun guix-hydra-build-running? (entry) + "Return non-nil, if hydra build is running." + (eq (guix-entry-value entry 'status) + 'running)) + +(defun guix-hydra-build-scheduled? (entry) + "Return non-nil, if hydra build is scheduled." + (eq (guix-entry-value entry 'status) + 'scheduled)) + +(defun guix-hydra-build-succeeded? (entry) + "Return non-nil, if hydra build succeeded." + (eq (guix-entry-value entry 'status) + 'succeeded)) + +(defun guix-hydra-build-cancelled? (entry) + "Return non-nil, if hydra build was cancelled." + (eq (guix-entry-value entry 'status) + 'cancelled)) + +(defun guix-hydra-build-failed? (entry) + "Return non-nil, if hydra build failed." + (memq (guix-entry-value entry 'status) + '(failed-build failed-dependency failed-other))) + + +;;; Hydra build 'info' + +(guix-hydra-info-define-interface hydra-build + :mode-name "Hydra-Build-Info" + :buffer-name "*Guix Hydra Build Info*" + :format '((name ignore (simple guix-info-heading)) + ignore + guix-hydra-build-info-insert-url + (time format (time)) + (status format guix-hydra-build-info-insert-status) + (project format (format guix-hydra-build-project)) + (jobset format (format guix-hydra-build-jobset)) + (job format (format guix-hydra-build-job)) + (system format (format guix-hydra-build-system)) + (priority format (format)))) + +(defface guix-hydra-build-info-project + '((t :inherit link)) + "Face for project names." + :group 'guix-hydra-build-info-faces) + +(defface guix-hydra-build-info-jobset + '((t :inherit link)) + "Face for jobsets." + :group 'guix-hydra-build-info-faces) + +(defface guix-hydra-build-info-job + '((t :inherit link)) + "Face for jobs." + :group 'guix-hydra-build-info-faces) + +(defface guix-hydra-build-info-system + '((t :inherit link)) + "Face for system names." + :group 'guix-hydra-build-info-faces) + +(defmacro guix-hydra-build-define-button (name) + "Define `guix-hydra-build-NAME' button." + (let* ((name-str (symbol-name name)) + (button-name (intern (concat "guix-hydra-build-" name-str))) + (face-name (intern (concat "guix-hydra-build-info-" name-str))) + (keyword (intern (concat ":" name-str)))) + `(define-button-type ',button-name + :supertype 'guix + 'face ',face-name + 'help-echo ,(format "\ +Show latest builds for this %s (with prefix, prompt for all parameters)" + name-str) + 'action (lambda (btn) + (let ((args (guix-hydra-build-latest-prompt-args + ,keyword (button-label btn)))) + (apply #'guix-hydra-build-get-display + 'latest args)))))) + +(guix-hydra-build-define-button project) +(guix-hydra-build-define-button jobset) +(guix-hydra-build-define-button job) +(guix-hydra-build-define-button system) + +(defun guix-hydra-build-info-insert-url (entry) + "Insert Hydra URL for the build ENTRY." + (guix-insert-button (guix-hydra-build-url (guix-entry-id entry)) + 'guix-url) + (when (guix-hydra-build-finished? entry) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Build log" + (lambda (btn) + (guix-hydra-build-view-log (button-get btn 'id))) + "View build log" + 'id (guix-entry-id entry)))) + +(defun guix-hydra-build-info-insert-status (status &optional _) + "Insert a string with build STATUS." + (insert (guix-hydra-build-status-string status))) + + +;;; Hydra build 'list' + +(guix-hydra-list-define-interface hydra-build + :mode-name "Hydra-Build-List" + :buffer-name "*Guix Hydra Build List*" + :format '((name nil 30 t) + (system nil 16 t) + (status guix-hydra-build-list-get-status 20 t) + (project nil 10 t) + (jobset nil 17 t) + (time guix-list-get-time 20 t))) + +(let ((map guix-hydra-build-list-mode-map)) + (define-key map (kbd "B") 'guix-hydra-build-list-latest-builds) + (define-key map (kbd "L") 'guix-hydra-build-list-view-log)) + +(defun guix-hydra-build-list-get-status (status &optional _) + "Return a string for build STATUS." + (guix-hydra-build-status-string status)) + +(defun guix-hydra-build-list-latest-builds (number &rest args) + "Display latest NUMBER of Hydra builds of the current job. +Interactively, prompt for NUMBER. With prefix argument, prompt +for all ARGS." + (interactive + (let ((entry (guix-list-current-entry))) + (guix-hydra-build-latest-prompt-args + :project (guix-entry-value entry 'project) + :jobset (guix-entry-value entry 'name) + :job (guix-entry-value entry 'job) + :system (guix-entry-value entry 'system)))) + (apply #'guix-hydra-latest-builds number args)) + +(defun guix-hydra-build-list-view-log () + "View build log of the current Hydra build." + (interactive) + (guix-hydra-build-view-log (guix-list-current-id))) + + +;;; Interactive commands + +;;;###autoload +(defun guix-hydra-latest-builds (number &rest args) + "Display latest NUMBER of Hydra builds. +ARGS are the same arguments as for `guix-hydra-build-latest-api-url'. +Interactively, prompt for NUMBER. With prefix argument, prompt +for all ARGS." + (interactive (guix-hydra-build-latest-prompt-args)) + (apply #'guix-hydra-build-get-display + 'latest number args)) + +;;;###autoload +(defun guix-hydra-queued-builds (number) + "Display the NUMBER of queued Hydra builds." + (interactive "NNumber of queued builds: ") + (guix-hydra-build-get-display 'queue number)) + +(provide 'guix-hydra-build) + +;;; guix-hydra-build.el ends here diff --git a/emacs/guix-hydra-jobset.el b/emacs/guix-hydra-jobset.el new file mode 100644 index 0000000000..a4a55a36f2 --- /dev/null +++ b/emacs/guix-hydra-jobset.el @@ -0,0 +1,162 @@ +;;; guix-hydra-jobset.el --- Interface for Hydra jobsets -*- lexical-binding: t -*- + +;; Copyright © 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides an interface for displaying Hydra jobsets in +;; 'list' and 'info' buffers. + +;;; Code: + +(require 'cl-lib) +(require 'guix-buffer) +(require 'guix-list) +(require 'guix-info) +(require 'guix-hydra) +(require 'guix-hydra-build) +(require 'guix-utils) + +(guix-hydra-define-entry-type hydra-jobset + :search-types '((project . guix-hydra-jobset-api-url)) + :filters '(guix-hydra-jobset-filter-id) + :filter-names '((nrscheduled . scheduled) + (nrsucceeded . succeeded) + (nrfailed . failed) + (nrtotal . total))) + +(defun guix-hydra-jobset-get-display (search-type &rest args) + "Search for Hydra builds and show results." + (apply #'guix-list-get-display-entries + 'hydra-jobset search-type args)) + + +;;; Defining URLs + +(defun guix-hydra-jobset-url (project jobset) + "Return Hydra URL of a PROJECT's JOBSET." + (guix-hydra-url "jobset/" project "/" jobset)) + +(defun guix-hydra-jobset-api-url (project) + "Return Hydra API URL for jobsets by PROJECT." + (guix-hydra-api-url "jobsets" + `(("project" . ,project)))) + + +;;; Filters for processing raw entries + +(defun guix-hydra-jobset-filter-id (entry) + "Add 'ID' parameter to 'hydra-jobset' ENTRY." + (cons `(id . ,(guix-entry-value entry 'name)) + entry)) + + +;;; Hydra jobset 'info' + +(guix-hydra-info-define-interface hydra-jobset + :mode-name "Hydra-Jobset-Info" + :buffer-name "*Guix Hydra Jobset Info*" + :format '((name ignore (simple guix-info-heading)) + ignore + guix-hydra-jobset-info-insert-url + (project format guix-hydra-jobset-info-insert-project) + (scheduled format (format guix-hydra-jobset-info-scheduled)) + (succeeded format (format guix-hydra-jobset-info-succeeded)) + (failed format (format guix-hydra-jobset-info-failed)) + (total format (format guix-hydra-jobset-info-total)))) + +(defface guix-hydra-jobset-info-scheduled + '((t)) + "Face used for the number of scheduled builds." + :group 'guix-hydra-jobset-info-faces) + +(defface guix-hydra-jobset-info-succeeded + '((t :inherit guix-hydra-build-status-succeeded)) + "Face used for the number of succeeded builds." + :group 'guix-hydra-jobset-info-faces) + +(defface guix-hydra-jobset-info-failed + '((t :inherit guix-hydra-build-status-failed)) + "Face used for the number of failed builds." + :group 'guix-hydra-jobset-info-faces) + +(defface guix-hydra-jobset-info-total + '((t)) + "Face used for the total number of builds." + :group 'guix-hydra-jobset-info-faces) + +(defun guix-hydra-jobset-info-insert-project (project entry) + "Insert PROJECT button for the jobset ENTRY." + (let ((jobset (guix-entry-value entry 'name))) + (guix-insert-button + project 'guix-hydra-build-project + 'action (lambda (btn) + (let ((args (guix-hydra-build-latest-prompt-args + :project (button-get btn 'project) + :jobset (button-get btn 'jobset)))) + (apply #'guix-hydra-build-get-display + 'latest args))) + 'project project + 'jobset jobset))) + +(defun guix-hydra-jobset-info-insert-url (entry) + "Insert Hydra URL for the jobset ENTRY." + (guix-insert-button (guix-hydra-jobset-url + (guix-entry-value entry 'project) + (guix-entry-value entry 'name)) + 'guix-url)) + + +;;; Hydra jobset 'list' + +(guix-hydra-list-define-interface hydra-jobset + :mode-name "Hydra-Jobset-List" + :buffer-name "*Guix Hydra Jobset List*" + :format '((name nil 25 t) + (project nil 10 t) + (scheduled nil 12 t) + (succeeded nil 12 t) + (failed nil 9 t) + (total nil 10 t))) + +(let ((map guix-hydra-jobset-list-mode-map)) + (define-key map (kbd "B") 'guix-hydra-jobset-list-latest-builds)) + +(defun guix-hydra-jobset-list-latest-builds (number &rest args) + "Display latest NUMBER of Hydra builds of the current jobset. +Interactively, prompt for NUMBER. With prefix argument, prompt +for all ARGS." + (interactive + (let ((entry (guix-list-current-entry))) + (guix-hydra-build-latest-prompt-args + :project (guix-entry-value entry 'project) + :jobset (guix-entry-value entry 'name)))) + (apply #'guix-hydra-latest-builds number args)) + + +;;; Interactive commands + +;;;###autoload +(defun guix-hydra-jobsets (project) + "Display jobsets of PROJECT." + (interactive (list (guix-hydra-read-project))) + (guix-hydra-jobset-get-display 'project project)) + +(provide 'guix-hydra-jobset) + +;;; guix-hydra-jobset.el ends here diff --git a/emacs/guix-hydra.el b/emacs/guix-hydra.el new file mode 100644 index 0000000000..429483946b --- /dev/null +++ b/emacs/guix-hydra.el @@ -0,0 +1,363 @@ +;;; guix-hydra.el --- Common code for interacting with Hydra -*- lexical-binding: t -*- + +;; Copyright © 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides some general code for 'list'/'info' interfaces for +;; Hydra (Guix build farm). + +;;; Code: + +(require 'json) +(require 'guix-buffer) +(require 'guix-entry) +(require 'guix-utils) +(require 'guix-help-vars) + +(guix-define-groups hydra) + +(defvar guix-hydra-job-regexp + (concat ".*\\." (regexp-opt guix-help-system-types) "\\'") + "Regexp matching a full name of Hydra job (including system).") + +(defun guix-hydra-message (entries search-type &rest _) + "Display a message after showing Hydra ENTRIES." + ;; XXX Add more messages maybe. + (when (null entries) + (if (eq search-type 'fake) + (message "The update is impossible due to lack of Hydra API.") + (message "Hydra has returned no results.")))) + +(defun guix-hydra-list-describe (ids) + "Describe 'hydra' entries with IDS (list of identifiers)." + (guix-buffer-display-entries + (guix-entries-by-ids ids (guix-buffer-current-entries)) + 'info (guix-buffer-current-entry-type) + ;; Hydra does not provide an API to receive builds/jobsets by + ;; IDs/names, so we use a 'fake' search type. + '(fake) + 'add)) + + +;;; Readers + +(defvar guix-hydra-projects + '("gnu" "guix") + "List of available Hydra projects.") + +(guix-define-readers + :completions-var guix-hydra-projects + :single-reader guix-hydra-read-project + :single-prompt "Project: ") + +(guix-define-readers + :single-reader guix-hydra-read-jobset + :single-prompt "Jobset: ") + +(guix-define-readers + :single-reader guix-hydra-read-job + :single-prompt "Job: ") + +(guix-define-readers + :completions-var guix-help-system-types + :single-reader guix-hydra-read-system + :single-prompt "System: ") + + +;;; Defining URLs + +(defvar guix-hydra-url "http://hydra.gnu.org" + "URL of the Hydra build farm.") + +(defun guix-hydra-url (&rest url-parts) + "Return Hydra URL." + (apply #'concat guix-hydra-url "/" url-parts)) + +(defun guix-hydra-api-url (type args) + "Return URL for receiving data using Hydra API. +TYPE is the name of an allowed method. +ARGS is alist of (KEY . VALUE) pairs. +Skip ARG, if VALUE is nil or an empty string." + (declare (indent 1)) + (let* ((fields (mapcar + (lambda (arg) + (pcase arg + (`(,key . ,value) + (unless (or (null value) + (equal "" value)) + (concat (guix-hexify key) "=" + (guix-hexify value)))) + (_ (error "Wrong argument '%s'" arg)))) + args)) + (fields (mapconcat #'identity (delq nil fields) "&"))) + (guix-hydra-url "api/" type "?" fields))) + + +;;; Receiving data from Hydra + +(defun guix-hydra-receive-data (url) + "Return output received from URL and processed with `json-read'." + (with-temp-buffer + (url-insert-file-contents url) + (goto-char (point-min)) + (let ((json-key-type 'symbol) + (json-array-type 'list) + (json-object-type 'alist)) + (json-read)))) + +(defun guix-hydra-get-entries (entry-type search-type &rest args) + "Receive ENTRY-TYPE entries from Hydra. +SEARCH-TYPE is one of the types defined by `guix-hydra-define-interface'." + (unless (eq search-type 'fake) + (let* ((url (apply #'guix-hydra-search-url + entry-type search-type args)) + (raw-entries (guix-hydra-receive-data url)) + (entries (guix-hydra-filter-entries + raw-entries + (guix-hydra-filters entry-type)))) + entries))) + + +;;; Filters for processing raw entries + +(defun guix-hydra-filter-entries (entries filters) + "Filter ENTRIES using FILTERS. +Call `guix-modify' on each entry from ENTRIES." + (mapcar (lambda (entry) + (guix-modify entry filters)) + entries)) + +(defun guix-hydra-filter-names (entry name-alist) + "Replace names of ENTRY parameters using NAME-ALIST. +Each element of NAME-ALIST is (OLD-NAME . NEW-NAME) pair." + (mapcar (lambda (param) + (pcase param + (`(,name . ,val) + (let ((new-name (guix-assq-value name-alist name))) + (if new-name + (cons new-name val) + param))))) + entry)) + +(defun guix-hydra-filter-boolean (entry params) + "Convert number PARAMS (0/1) of ENTRY to boolean values (nil/t)." + (mapcar (lambda (param) + (pcase param + (`(,name . ,val) + (if (memq name params) + (cons name (guix-number->bool val)) + param)))) + entry)) + + +;;; Wrappers for defined variables + +(defvar guix-hydra-entry-type-data nil + "Alist with hydra entry type data. +This alist is filled by `guix-hydra-define-entry-type' macro.") + +(defun guix-hydra-entry-type-value (entry-type symbol) + "Return SYMBOL's value for ENTRY-TYPE from `guix-hydra'." + (symbol-value (guix-assq-value guix-hydra-entry-type-data + entry-type symbol))) + +(defun guix-hydra-search-url (entry-type search-type &rest args) + "Return URL to receive ENTRY-TYPE entries from Hydra." + (apply (guix-assq-value (guix-hydra-entry-type-value + entry-type 'search-types) + search-type) + args)) + +(defun guix-hydra-filters (entry-type) + "Return a list of filters for ENTRY-TYPE." + (guix-hydra-entry-type-value entry-type 'filters)) + + +;;; Interface definers + +(defmacro guix-hydra-define-entry-type (entry-type &rest args) + "Define general code for ENTRY-TYPE. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Required keywords: + + - `:search-types' - default value of the generated + `guix-ENTRY-TYPE-search-types' variable. + +Optional keywords: + + - `:filters' - default value of the generated + `guix-ENTRY-TYPE-filters' variable. + + - `:filter-names' - if specified, a generated + `guix-ENTRY-TYPE-filter-names' function for filtering these + names will be added to `guix-ENTRY-TYPE-filters' variable. + + - `:filter-boolean-params' - if specified, a generated + `guix-ENTRY-TYPE-filter-boolean' function for filtering these + names will be added to `guix-ENTRY-TYPE-filters' variable. + +The rest keyword arguments are passed to +`guix-define-entry-type' macro." + (declare (indent 1)) + (let* ((entry-type-str (symbol-name entry-type)) + (prefix (concat "guix-" entry-type-str)) + (search-types-var (intern (concat prefix "-search-types"))) + (filters-var (intern (concat prefix "-filters"))) + (get-fun (intern (concat prefix "-get-entries")))) + (guix-keyword-args-let args + ((search-types-val :search-types) + (filters-val :filters) + (filter-names-val :filter-names) + (filter-bool-val :filter-boolean-params)) + `(progn + (defvar ,search-types-var ,search-types-val + ,(format "\ +Alist of search types and according URL functions. +Functions are used to define URL to receive '%s' entries." + entry-type-str)) + + (defvar ,filters-var ,filters-val + ,(format "\ +List of filters for '%s' parameters. +Each filter is a function that should take an entry as a single +argument, and should also return an entry." + entry-type-str)) + + ,(when filter-bool-val + (let ((filter-bool-var (intern (concat prefix + "-filter-boolean-params"))) + (filter-bool-fun (intern (concat prefix + "-filter-boolean")))) + `(progn + (defvar ,filter-bool-var ,filter-bool-val + ,(format "\ +List of '%s' parameters that should be transformed to boolean values." + entry-type-str)) + + (defun ,filter-bool-fun (entry) + ,(format "\ +Run `guix-hydra-filter-boolean' with `%S' variable." + filter-bool-var) + (guix-hydra-filter-boolean entry ,filter-bool-var)) + + (setq ,filters-var + (cons ',filter-bool-fun ,filters-var))))) + + ;; Do not move this clause up!: name filtering should be + ;; performed before any other filtering, so this filter should + ;; be consed after the boolean filter. + ,(when filter-names-val + (let* ((filter-names-var (intern (concat prefix + "-filter-names"))) + (filter-names-fun filter-names-var)) + `(progn + (defvar ,filter-names-var ,filter-names-val + ,(format "\ +Alist of '%s' parameter names returned by Hydra API and names +used internally by the elisp code of this package." + entry-type-str)) + + (defun ,filter-names-fun (entry) + ,(format "\ +Run `guix-hydra-filter-names' with `%S' variable." + filter-names-var) + (guix-hydra-filter-names entry ,filter-names-var)) + + (setq ,filters-var + (cons ',filter-names-fun ,filters-var))))) + + (defun ,get-fun (search-type &rest args) + ,(format "\ +Receive '%s' entries. +See `guix-hydra-get-entries' for details." + entry-type-str) + (apply #'guix-hydra-get-entries + ',entry-type search-type args)) + + (guix-alist-put! + '((search-types . ,search-types-var) + (filters . ,filters-var)) + 'guix-hydra-entry-type-data ',entry-type) + + (guix-define-entry-type ,entry-type + :parent-group guix-hydra + :parent-faces-group guix-hydra-faces + ,@%foreign-args))))) + +(defmacro guix-hydra-define-interface (buffer-type entry-type &rest args) + "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. + +This macro should be called after calling +`guix-hydra-define-entry-type' with the same ENTRY-TYPE. + +ARGS are passed to `guix-BUFFER-TYPE-define-interface' macro." + (declare (indent 2)) + (let* ((entry-type-str (symbol-name entry-type)) + (buffer-type-str (symbol-name buffer-type)) + (get-fun (intern (concat "guix-" entry-type-str + "-get-entries"))) + (definer (intern (concat "guix-" buffer-type-str + "-define-interface")))) + `(,definer ,entry-type + :get-entries-function ',get-fun + :message-function 'guix-hydra-message + ,@args))) + +(defmacro guix-hydra-info-define-interface (entry-type &rest args) + "Define 'info' interface for displaying ENTRY-TYPE entries. +See `guix-hydra-define-interface'." + (declare (indent 1)) + `(guix-hydra-define-interface info ,entry-type + ,@args)) + +(defmacro guix-hydra-list-define-interface (entry-type &rest args) + "Define 'list' interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Optional keywords: + + - `:describe-function' - default value of the generated + `guix-ENTRY-TYPE-list-describe-function' variable (if not + specified, use `guix-hydra-list-describe'). + +The rest keyword arguments are passed to +`guix-hydra-define-interface' macro." + (declare (indent 1)) + (guix-keyword-args-let args + ((describe-val :describe-function)) + `(guix-hydra-define-interface list ,entry-type + :describe-function ,(or describe-val ''guix-hydra-list-describe) + ,@args))) + + +(defvar guix-hydra-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group (or "guix-hydra-define-entry-type" + "guix-hydra-define-interface" + "guix-hydra-info-define-interface" + "guix-hydra-list-define-interface")) + symbol-end) + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode guix-hydra-font-lock-keywords) + +(provide 'guix-hydra) + +;;; guix-hydra.el ends here diff --git a/emacs/guix-info.el b/emacs/guix-info.el index 1c7e79b954..644533eb29 100644 --- a/emacs/guix-info.el +++ b/emacs/guix-info.el @@ -1,4 +1,4 @@ -;;; guix-info.el --- Info buffers for displaying entries -*- lexical-binding: t -*- +;;; guix-info.el --- 'Info' buffer interface for displaying data -*- lexical-binding: t -*- ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> ;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> @@ -20,23 +20,16 @@ ;;; Commentary: -;; This file provides a help-like buffer for displaying information -;; about Guix packages and generations. +;; This file provides 'info' (help-like) buffer interface for displaying +;; an arbitrary data. ;;; Code: -(require 'guix-base) +(require 'guix-buffer) +(require 'guix-entry) (require 'guix-utils) -(defgroup guix-info nil - "General settings for info buffers." - :prefix "guix-info-" - :group 'guix) - -(defgroup guix-info-faces nil - "Faces for info buffers." - :group 'guix-info - :group 'guix-faces) +(guix-define-buffer-type info) (defface guix-info-heading '((((type tty pc) (class color)) :weight bold) @@ -80,122 +73,115 @@ "Mouse face used for action buttons." :group 'guix-info-faces) -(defcustom guix-info-ignore-empty-vals nil +(defcustom guix-info-ignore-empty-values nil "If non-nil, do not display parameters with nil values." :type 'boolean :group 'guix-info) +(defcustom guix-info-fill t + "If non-nil, fill string parameters to fit the window. +If nil, insert text parameters (like synopsis or description) in +a raw form." + :type 'boolean + :group 'guix-info) + (defvar guix-info-param-title-format "%-18s: " "String used to format a title of a parameter. It should be a '%s'-sequence. After inserting a title formatted with this string, a value of the parameter is inserted. -This string is used by `guix-info-insert-title-default'.") +This string is used by `guix-info-insert-title-format'.") -(defvar guix-info-multiline-prefix (make-string 20 ?\s) +(defvar guix-info-multiline-prefix + (make-string (length (format guix-info-param-title-format " ")) + ?\s) "String used to format multi-line parameter values. If a value occupies more than one line, this string is inserted in the beginning of each line after the first one. -This string is used by `guix-info-insert-val-default'.") +This string is used by `guix-info-insert-value-format'.") (defvar guix-info-indent 2 "Number of spaces used to indent various parts of inserted text.") -(defvar guix-info-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) - (source guix-package-info-insert-source - 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)) - (output - (name guix-package-info-name) - (version guix-output-info-insert-version) - (output guix-output-info-insert-output) - (source guix-package-info-insert-source - guix-info-insert-title-simple) - (path guix-package-info-insert-output-path - guix-info-insert-title-simple) - (dependencies guix-package-info-insert-output-dependencies - guix-info-insert-title-simple) - (license guix-package-info-license) - (synopsis guix-package-info-synopsis) - (description guix-package-info-insert-description - 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)) - (generation - (number guix-generation-info-insert-number) - (current guix-generation-info-insert-current) - (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 source location home-url - license inputs native-inputs propagated-inputs description) - (output name version output synopsis source path dependencies location - home-url license inputs native-inputs propagated-inputs - description) - (installed path dependencies) - (generation number prev-number current 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-assq-value 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-assq-value guix-info-displayed-params - entry-type)) + +;;; Wrappers for 'info' variables + +(defvar guix-info-data nil + "Alist with 'info' data. +This alist is filled by `guix-info-define-interface' macro.") + +(defun guix-info-value (entry-type symbol) + "Return SYMBOL's value for ENTRY-TYPE from `guix-info-data'." + (symbol-value (guix-assq-value guix-info-data entry-type symbol))) + +(defun guix-info-param-title (entry-type param) + "Return a title of an ENTRY-TYPE parameter PARAM." + (guix-buffer-param-title 'info entry-type param)) + +(defun guix-info-format (entry-type) + "Return 'info' format for ENTRY-TYPE." + (guix-info-value entry-type 'format)) + +(defun guix-info-displayed-params (entry-type) + "Return a list of ENTRY-TYPE parameters that should be displayed." + (delq nil + (mapcar (lambda (spec) + (pcase spec + (`(,param . ,_) param))) + (guix-info-format entry-type)))) + + +;;; Inserting entries + +(defvar guix-info-title-aliases + '((format . guix-info-insert-title-format) + (simple . guix-info-insert-title-simple)) + "Alist of aliases and functions to insert titles.") + +(defvar guix-info-value-aliases + '((format . guix-info-insert-value-format) + (indent . guix-info-insert-value-indent) + (simple . guix-info-insert-value-simple) + (time . guix-info-insert-time)) + "Alist of aliases and functions to insert values.") + +(defun guix-info-title-function (fun-or-alias) + "Convert FUN-OR-ALIAS into a function to insert a title." + (or (guix-assq-value guix-info-title-aliases fun-or-alias) + fun-or-alias)) + +(defun guix-info-value-function (fun-or-alias) + "Convert FUN-OR-ALIAS into a function to insert a value." + (or (guix-assq-value guix-info-value-aliases fun-or-alias) + fun-or-alias)) + +(defun guix-info-title-method->function (method) + "Convert title METHOD into a function to insert a title." + (pcase method + ((pred null) #'ignore) + ((pred symbolp) (guix-info-title-function method)) + (`(,fun-or-alias . ,rest-args) + (lambda (title) + (apply (guix-info-title-function fun-or-alias) + title rest-args))) + (_ (error "Unknown title method '%S'" method)))) + +(defun guix-info-value-method->function (method) + "Convert value METHOD into a function to insert a value." + (pcase method + ((pred null) #'ignore) + ((pred functionp) method) + (`(,fun-or-alias . ,rest-args) + (lambda (value _) + (apply (guix-info-value-function fun-or-alias) + value rest-args))) + (_ (error "Unknown value method '%S'" method)))) + +(defun guix-info-fill-column () + "Return fill column for the current window." + (min (window-width) fill-column)) (defun guix-info-get-indent (&optional level) "Return `guix-info-indent' \"multiplied\" by LEVEL spaces. @@ -207,124 +193,128 @@ LEVEL is 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'." + "Display ENTRY-TYPE ENTRIES in the current info buffer." (guix-mapinsert (lambda (entry) (guix-info-insert-entry entry entry-type)) entries guix-info-delimiter)) -(defun guix-info-insert-entry-default (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-entry (entry entry-type &optional indent-level) "Insert ENTRY of ENTRY-TYPE into the current info buffer. -Use `guix-info-insert-ENTRY-TYPE-function' or -`guix-info-insert-entry-default' if it is nil." - (let* ((var (intern (concat "guix-info-insert-" - (symbol-name entry-type) - "-function"))) - (fun (symbol-value var))) - (if (functionp fun) - (funcall fun entry) - (guix-info-insert-entry-default entry entry-type indent-level)))) - -(defun guix-info-insert-param (param entry entry-type) +If INDENT-LEVEL is non-nil, indent displayed data by this number +of `guix-info-indent' spaces." + (guix-with-indent (* (or indent-level 0) + guix-info-indent) + (dolist (spec (guix-info-format entry-type)) + (guix-info-insert-entry-unit spec entry entry-type)))) + +(defun guix-info-insert-entry-unit (format-spec entry entry-type) "Insert title and value of a PARAM at point. ENTRY is alist with parameters and their values. ENTRY-TYPE is a type of ENTRY." - (let ((val (guix-assq-value 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." + (pcase format-spec + ((pred functionp) + (funcall format-spec entry) + (insert "\n")) + (`(,param ,title-method ,value-method) + (let ((value (guix-entry-value entry param))) + (unless (and guix-info-ignore-empty-values (null value)) + (let ((title (guix-info-param-title entry-type param)) + (insert-title (guix-info-title-method->function title-method)) + (insert-value (guix-info-value-method->function value-method))) + (funcall insert-title title) + (funcall insert-value value entry) + (insert "\n"))))) + (_ (error "Unknown format specification '%S'" format-spec)))) + +(defun guix-info-insert-title-simple (title &optional face) + "Insert \"TITLE: \" string at point. +If FACE is nil, use `guix-info-param-title'." (guix-format-insert title (or face 'guix-info-param-title) - (or format guix-info-param-title-format))) + "%s: ")) -(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-time (seconds &optional _) +(defun guix-info-insert-title-format (title &optional face) + "Insert TITLE using `guix-info-param-title-format' at point. +If FACE is nil, use `guix-info-param-title'." + (guix-format-insert title + (or face 'guix-info-param-title) + guix-info-param-title-format)) + +(defun guix-info-insert-value-simple (value &optional button-or-face indent) + "Format and insert parameter VALUE at point. + +VALUE may be split into several short lines to fit the current +window, depending on `guix-info-fill', and each line is indented +with INDENT number of spaces. + +If BUTTON-OR-FACE is a button type symbol, transform VALUE into +this (these) button(s) and insert each one on a new line. If it +is a face symbol, propertize inserted line(s) with this face." + (or indent (setq indent 0)) + (guix-with-indent indent + (let* ((button? (guix-button-type? button-or-face)) + (face (unless button? button-or-face)) + (fill-col (unless (or button? + (and (stringp value) + (not guix-info-fill))) + (- (guix-info-fill-column) indent))) + (value (if (and value button?) + (guix-buttonize value button-or-face "\n") + value))) + (guix-split-insert value face fill-col "\n")))) + +(defun guix-info-insert-value-indent (value &optional button-or-face) + "Format and insert parameter VALUE at point. + +This function is intended to be called after inserting a title +with `guix-info-insert-title-simple'. + +VALUE may be split into several short lines to fit the current +window, depending on `guix-info-fill', and each line is indented +with `guix-info-indent'. + +For the meaning of BUTTON-OR-FACE, see `guix-info-insert-value-simple'." + (when value (insert "\n")) + (guix-info-insert-value-simple value button-or-face guix-info-indent)) + +(defun guix-info-insert-value-format (value &optional button-or-face + &rest button-properties) + "Format and insert parameter VALUE at point. + +This function is intended to be called after inserting a title +with `guix-info-insert-title-format'. + +VALUE may be split into several short lines to fit the current +window, depending on `guix-info-fill' and +`guix-info-multiline-prefix'. If VALUE is a list, its elements +will be separated with `guix-list-separator'. + +If BUTTON-OR-FACE is a button type symbol, transform VALUE into +this (these) button(s). If it is a face symbol, propertize +inserted line(s) with this face. + +BUTTON-PROPERTIES are passed to `guix-buttonize' (only if +BUTTON-OR-FACE is a button type)." + (let* ((button? (guix-button-type? button-or-face)) + (face (unless button? button-or-face)) + (fill-col (when (or button? + guix-info-fill + (not (stringp value))) + (- (guix-info-fill-column) + (length guix-info-multiline-prefix)))) + (value (if (and value button?) + (apply #'guix-buttonize + value button-or-face guix-list-separator + button-properties) + value))) + (guix-split-insert value face fill-col + (concat "\n" guix-info-multiline-prefix)))) + +(defun guix-info-insert-time (seconds &optional face) "Insert formatted time string using SECONDS at point." - (guix-info-insert-val-default (guix-get-time-string seconds) - 'guix-info-time)) + (guix-format-insert (guix-get-time-string seconds) + (or face 'guix-info-time))) ;;; Buttons @@ -359,21 +349,6 @@ VAL is a list, call the function on each element of this list." 'action (lambda (btn) (browse-url (button-label btn)))) -(define-button-type 'guix-package-location - :supertype 'guix - 'face 'guix-package-info-location - 'help-echo "Find location of this package" - 'action (lambda (btn) - (guix-find-location (button-label btn)))) - -(define-button-type 'guix-package-name - :supertype 'guix - 'face 'guix-package-info-name-button - 'help-echo "Describe this package" - 'action (lambda (btn) - (guix-get-show-entries guix-profile 'info guix-package-info-type - 'name (button-label btn)))) - (defun guix-info-button-copy-label (&optional pos) "Copy a label of the button at POS into kill ring. If POS is nil, use the current point position." @@ -395,496 +370,112 @@ See `insert-text-button' for the meaning of PROPERTIES." 'help-echo message properties)) -(defun guix-info-insert-file-path (path &optional _) - "Make button from file PATH and insert it at point." - (guix-insert-button path 'guix-file)) - -(defun guix-info-insert-url (url &optional _) - "Make button from URL and insert it at point." - (guix-insert-button url 'guix-url)) - +;;; Major mode and interface definer + (defvar guix-info-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent - map (make-composed-keymap (list guix-root-map button-buffer-map) + map (make-composed-keymap (list guix-buffer-map button-buffer-map) special-mode-map)) map) - "Parent keymap for info buffers.") + "Keymap for `guix-info-mode' buffers.") (define-derived-mode guix-info-mode special-mode "Guix-Info" - "Parent mode for displaying information in info buffers.") + "Parent mode for displaying data in 'info' form." + (setq-local revert-buffer-function 'guix-buffer-revert)) + +(defun guix-info-mode-initialize () + "Set up the current 'info' buffer." + ;; Without this, syntactic fontification is performed, and it may + ;; break our highlighting. For example, description of "emacs-typo" + ;; package contains a single " (double-quote) character, so the + ;; default syntactic fontification highlights the rest text after it + ;; as a string. See (info "(elisp) Font Lock Basics") for details. + (setq font-lock-defaults '(nil t))) + +(defmacro guix-info-define-interface (entry-type &rest args) + "Define 'info' interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Required keywords: + + - `:format' - default value of the generated + `guix-ENTRY-TYPE-info-format' variable. + +The rest keyword arguments are passed to +`guix-buffer-define-interface' macro." + (declare (indent 1)) + (let* ((entry-type-str (symbol-name entry-type)) + (prefix (concat "guix-" entry-type-str "-info")) + (group (intern prefix)) + (format-var (intern (concat prefix "-format")))) + (guix-keyword-args-let args + ((show-entries-val :show-entries-function) + (format-val :format)) + `(progn + (defcustom ,format-var ,format-val + ,(format "\ +List of methods for inserting '%s' entry. +Each METHOD should be either a function or should have the +following form: + + (PARAM INSERT-TITLE INSERT-VALUE) + +If METHOD is a function, it is called with an entry as argument. + +PARAM is a name of '%s' entry parameter. + +INSERT-TITLE may be either a symbol or a list. If it is a +symbol, it should be a function or an alias from +`guix-info-title-aliases', in which case it is called with title +as argument. If it is a list, it should have a +form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is +called with title and ARGS as arguments. + +INSERT-VALUE may be either a symbol or a list. If it is a +symbol, it should be a function or an alias from +`guix-info-value-aliases', in which case it is called with value +and entry as arguments. If it is a list, it should have a +form (FUN-OR-ALIAS [ARGS ...]), in which case FUN-OR-ALIAS is +called with value and ARGS as arguments. + +Parameters are inserted in the same order as defined by this list. +After calling each METHOD, a new line is inserted." + entry-type-str entry-type-str) + :type 'sexp + :group ',group) + + (guix-alist-put! + '((format . ,format-var)) + 'guix-info-data ',entry-type) + + ,(if show-entries-val + `(guix-buffer-define-interface info ,entry-type + :show-entries-function ,show-entries-val + ,@%foreign-args) + + (let ((insert-fun (intern (concat prefix "-insert-entries")))) + `(progn + (defun ,insert-fun (entries) + ,(format "\ +Print '%s' ENTRIES in the current 'info' buffer." + entry-type-str) + (guix-info-insert-entries entries ',entry-type)) + + (guix-buffer-define-interface info ,entry-type + :insert-entries-function ',insert-fun + :mode-init-function 'guix-info-mode-initialize + ,@%foreign-args)))))))) -;;; Displaying packages - -(guix-define-buffer-type info package - :required (id installed non-unique)) - -(defface guix-package-info-heading - '((t :inherit guix-info-heading)) - "Face for package name and version headings." - :group 'guix-package-info-faces) - -(defface guix-package-info-name - '((t :inherit font-lock-keyword-face)) - "Face used for a name of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-name-button - '((t :inherit button)) - "Face used for a full name that can be used to describe a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-version - '((t :inherit font-lock-builtin-face)) - "Face used for a version of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-synopsis - '((((type tty pc) (class color)) :weight bold) - (t :height 1.1 :weight bold :inherit variable-pitch)) - "Face used for a synopsis of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-description - '((t)) - "Face used for a description of a package." - :group 'guix-package-info-faces) +(defvar guix-info-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group "guix-info-define-interface") + symbol-end) + . 1)))) -(defface guix-package-info-license - '((t :inherit font-lock-string-face)) - "Face used for a license of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-location - '((t :inherit link)) - "Face used for a location of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-installed-outputs - '((default :weight bold) - (((class color) (min-colors 88) (background light)) - :foreground "ForestGreen") - (((class color) (min-colors 88) (background dark)) - :foreground "PaleGreen") - (((class color) (min-colors 8)) - :foreground "green") - (t :underline t)) - "Face used for installed outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-uninstalled-outputs - '((t :weight bold)) - "Face used for uninstalled outputs of a package." - :group 'guix-package-info-faces) - -(defface guix-package-info-obsolete - '((t :inherit error)) - "Face used if a package is obsolete." - :group 'guix-package-info-faces) - -(defvar guix-info-insert-package-function - #'guix-package-info-insert-with-heading - "Function used to insert a package information. -It is called with a single argument - alist of package parameters. -If nil, insert package in a default way.") - -(defvar guix-package-info-heading-params '(synopsis description) - "List of parameters displayed in a heading along with name and version.") - -(defcustom guix-package-info-fill-heading t - "If nil, insert heading parameters in a raw form, without -filling them to fit the window." - :type 'boolean - :group 'guix-package-info) - -(defun guix-package-info-insert-heading (entry) - "Insert the heading for package ENTRY. -Show package name, version, and `guix-package-info-heading-params'." - (guix-format-insert (concat (guix-assq-value entry 'name) " " - (guix-assq-value entry 'version)) - 'guix-package-info-heading) - (insert "\n\n") - (mapc (lambda (param) - (let ((val (guix-assq-value entry param)) - (face (guix-get-symbol (symbol-name param) - 'info 'package))) - (when val - (let* ((col (min (window-width) fill-column)) - (val (if guix-package-info-fill-heading - (guix-get-filled-string val col) - val))) - (guix-format-insert val (and (facep face) face)) - (insert "\n\n"))))) - guix-package-info-heading-params)) - -(defun guix-package-info-insert-with-heading (entry) - "Insert package ENTRY with its heading at point." - (guix-package-info-insert-heading entry) - (mapc (lambda (param) - (unless (or (memq param '(name version)) - (memq param guix-package-info-heading-params)) - (guix-info-insert-param param entry 'package))) - (guix-info-get-displayed-params 'package))) - -(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-location)) - -(defmacro guix-package-info-define-insert-inputs (&optional type) - "Define a face and a function for inserting package inputs. -TYPE is a type of inputs. -Function name is `guix-package-info-insert-TYPE-inputs'. -Face name is `guix-package-info-TYPE-inputs'." - (let* ((type-str (symbol-name type)) - (type-name (and type (concat type-str "-"))) - (type-desc (and type (concat type-str " "))) - (face (intern (concat "guix-package-info-" type-name "inputs"))) - (btn (intern (concat "guix-package-" type-name "input"))) - (fun (intern (concat "guix-package-info-insert-" type-name "inputs")))) - `(progn - (defface ,face - '((t :inherit guix-package-info-name-button)) - ,(concat "Face used for " type-desc "inputs of a package.") - :group 'guix-package-info-faces) - - (define-button-type ',btn - :supertype 'guix-package-name - 'face ',face) - - (defun ,fun (inputs &optional _) - ,(concat "Make buttons from " type-desc "INPUTS and insert them at point.") - (guix-package-info-insert-full-names inputs ',btn))))) - -(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 button-type) - "Make BUTTON-TYPE buttons from package NAMES and insert them at point. -NAMES is a list of strings." - (if names - (guix-info-insert-val-default - (with-temp-buffer - (guix-mapinsert (lambda (name) - (guix-insert-button name button-type)) - names - guix-list-separator) - (buffer-substring (point-min) (point-max)))) - (guix-format-insert nil))) - - -;;; 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.") - -(defvar guix-info-insert-installed-function nil - "Function used to insert an installed information. -It is called with a single argument - alist of installed -parameters (`output', `path', `dependencies'). -If nil, insert installed info in a default way.") - -(defun guix-package-info-insert-outputs (outputs entry) - "Insert OUTPUTS from package ENTRY at point." - (and (guix-assq-value entry 'obsolete) - (guix-package-info-insert-obsolete-text)) - (and (guix-assq-value entry 'non-unique) - (guix-assq-value 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-insert-button full-name 'guix-package-name) - (insert " package.")) - -(defun guix-package-info-insert-output (output entry) - "Insert OUTPUT at point. -Make some fancy text with buttons and additional stuff if the -current OUTPUT is installed (if there is such output in -`installed' parameter of a package ENTRY)." - (let* ((installed (guix-assq-value entry 'installed)) - (obsolete (guix-assq-value entry 'obsolete)) - (installed-entry (cl-find-if - (lambda (entry) - (string= (guix-assq-value 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 - guix-profile - `((,(button-get btn 'action-type) (,(button-get btn 'id) - ,(button-get btn 'output)))) - (current-buffer))) - (concat type-str " '" full-name "'") - 'action-type type - 'id (or (guix-assq-value entry 'package-id) - (guix-assq-value 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)) - -(defalias 'guix-package-info-insert-output-dependencies - 'guix-package-info-insert-output-path) - - -;;; Inserting a source - -(defface guix-package-info-source - '((t :inherit link :underline nil)) - "Face used for a source URL of a package." - :group 'guix-package-info-faces) - -(defcustom guix-package-info-auto-find-source nil - "If non-nil, find a source file after pressing a \"Show\" button. -If nil, just display the source file path without finding." - :type 'boolean - :group 'guix-package-info) - -(defcustom guix-package-info-auto-download-source t - "If nil, do not automatically download a source file if it doesn't exist. -After pressing a \"Show\" button, a derivation of the package -source is calculated and a store file path is displayed. If this -variable is non-nil and the source file does not exist in the -store, it will be automatically downloaded (with a possible -prompt depending on `guix-operation-confirm' variable)." - :type 'boolean - :group 'guix-package-info) - -(defvar guix-package-info-download-buffer nil - "Buffer from which a current download operation was performed.") - -(define-button-type 'guix-package-source - :supertype 'guix - 'face 'guix-package-info-source - 'help-echo "" - 'action (lambda (_) - ;; As a source may not be a real URL (e.g., "mirror://..."), - ;; no action is bound to a source button. - (message "Yes, this is the source URL. What did you expect?"))) - -(defun guix-package-info-insert-source-url (url &optional _) - "Make button from source URL and insert it at point." - (guix-insert-button url 'guix-package-source)) - -(defun guix-package-info-show-source (entry-id package-id) - "Show file name of a package source in the current info buffer. -Find the file if needed (see `guix-package-info-auto-find-source'). -ENTRY-ID is an ID of the current entry (package or output). -PACKAGE-ID is an ID of the package which source to show." - (let* ((entry (guix-get-entry-by-id entry-id guix-entries)) - (file (guix-package-source-path package-id))) - (or file - (error "Couldn't define file path of the package source")) - (let* ((new-entry (cons (cons 'source-file file) - entry)) - (entries (cl-substitute-if - new-entry - (lambda (entry) - (equal (guix-assq-value entry 'id) - entry-id)) - guix-entries - :count 1))) - (guix-redisplay-buffer :entries entries) - (if (file-exists-p file) - (if guix-package-info-auto-find-source - (guix-find-file file) - (message "The source store path is displayed.")) - (if guix-package-info-auto-download-source - (guix-package-info-download-source package-id) - (message "The source does not exist in the store.")))))) - -(defun guix-package-info-download-source (package-id) - "Download a source of the package PACKAGE-ID." - (setq guix-package-info-download-buffer (current-buffer)) - (guix-package-source-build-derivation - package-id - "The source does not exist in the store. Download it?")) - -(defun guix-package-info-insert-source (source entry) - "Insert SOURCE from package ENTRY at point. -SOURCE is a list of URLs." - (guix-info-insert-indent) - (if (null source) - (guix-format-insert nil) - (let* ((source-file (guix-assq-value entry 'source-file)) - (entry-id (guix-assq-value entry 'id)) - (package-id (or (guix-assq-value entry 'package-id) - entry-id))) - (if (null source-file) - (guix-info-insert-action-button - "Show" - (lambda (btn) - (guix-package-info-show-source (button-get btn 'entry-id) - (button-get btn 'package-id))) - "Show the source store path of the current package" - 'entry-id entry-id - 'package-id package-id) - (unless (file-exists-p source-file) - (guix-info-insert-action-button - "Download" - (lambda (btn) - (guix-package-info-download-source - (button-get btn 'package-id))) - "Download the source into the store" - 'package-id package-id)) - (guix-info-insert-val-simple source-file - #'guix-info-insert-file-path)) - (guix-info-insert-val-simple source - #'guix-package-info-insert-source-url)))) - -(defun guix-package-info-redisplay-after-download () - "Redisplay an 'info' buffer after downloading the package source. -This function is used to hide a \"Download\" button if needed." - (when (buffer-live-p guix-package-info-download-buffer) - (guix-redisplay-buffer :buffer guix-package-info-download-buffer) - (setq guix-package-info-download-buffer nil))) - -(add-hook 'guix-after-source-download-hook - 'guix-package-info-redisplay-after-download) - - -;;; Displaying outputs - -(guix-define-buffer-type info output - :buffer-name "*Guix Package Info*" - :required (id package-id installed non-unique)) - -(defvar guix-info-insert-output-function nil - "Function used to insert an output information. -It is called with a single argument - alist of output parameters. -If nil, insert output in a default way.") - -(defun guix-output-info-insert-version (version entry) - "Insert output VERSION and obsolete text if needed at point." - (guix-info-insert-val-default version - 'guix-package-info-version) - (and (guix-assq-value entry 'obsolete) - (guix-package-info-insert-obsolete-text))) - -(defun guix-output-info-insert-output (output entry) - "Insert OUTPUT and action buttons at point." - (let* ((installed (guix-assq-value entry 'installed)) - (obsolete (guix-assq-value entry 'obsolete)) - (action-type (if installed 'delete 'install))) - (guix-info-insert-val-default - output - (if installed - 'guix-package-info-installed-outputs - 'guix-package-info-uninstalled-outputs)) - (guix-info-insert-indent) - (guix-package-info-insert-action-button action-type entry output) - (when obsolete - (guix-info-insert-indent) - (guix-package-info-insert-action-button 'upgrade entry output)))) - - -;;; 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-faces) - -(defface guix-generation-info-current - '((t :inherit guix-package-info-installed-outputs)) - "Face used if a generation is the current one." - :group 'guix-generation-info-faces) - -(defface guix-generation-info-not-current - '((t nil)) - "Face used if a generation is not the current one." - :group 'guix-generation-info-faces) - -(defvar guix-info-insert-generation-function nil - "Function used to insert a generation information. -It is called with a single argument - alist of generation parameters. -If nil, insert generation in a default way.") - -(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-get-show-entries guix-profile 'list guix-package-list-type - '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) - (guix-delete-generations guix-profile (list (button-get btn 'number)) - (current-buffer))) - "Delete this generation" - 'number number)) - -(defun guix-generation-info-insert-current (val entry) - "Insert boolean value VAL showing whether this generation is current." - (if val - (guix-info-insert-val-default "Yes" 'guix-generation-info-current) - (guix-info-insert-val-default "No" 'guix-generation-info-not-current) - (guix-info-insert-indent) - (guix-info-insert-action-button - "Switch" - (lambda (btn) - (guix-switch-to-generation guix-profile (button-get btn 'number) - (current-buffer))) - "Switch to this generation (make it the current one)" - 'number (guix-assq-value entry 'number)))) +(font-lock-add-keywords 'emacs-lisp-mode guix-info-font-lock-keywords) (provide 'guix-info) diff --git a/emacs/guix-list.el b/emacs/guix-list.el index 560ae6a86f..7e57f42cb2 100644 --- a/emacs/guix-list.el +++ b/emacs/guix-list.el @@ -1,4 +1,4 @@ -;;; guix-list.el --- List buffers for displaying entries -*- lexical-binding: t -*- +;;; guix-list.el --- 'List' buffer interface for displaying data -*- lexical-binding: t -*- ;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> @@ -19,26 +19,19 @@ ;;; Commentary: -;; This file provides a list-like buffer for displaying information -;; about Guix packages and generations. +;; This file provides 'list' buffer interface for displaying an arbitrary +;; data. ;;; Code: (require 'cl-lib) (require 'tabulated-list) +(require 'guix-buffer) (require 'guix-info) -(require 'guix-base) +(require 'guix-entry) (require 'guix-utils) -(defgroup guix-list nil - "General settings for list buffers." - :prefix "guix-list-" - :group 'guix) - -(defgroup guix-list-faces nil - "Faces for list buffers." - :group 'guix-list - :group 'guix-faces) +(guix-define-buffer-type list) (defface guix-list-file-path '((t :inherit guix-info-file-path)) @@ -50,153 +43,165 @@ "Face used for time stamps." :group 'guix-list-faces) -(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)) - (output - (name 20 t) - (version 10 nil) - (output 9 t) - (installed 12 t) - (synopsis 30 nil)) - (generation - (number 5 - ,(lambda (a b) (guix-list-sort-numerically 0 a b)) - :right-align t) - (current 10 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)) - (output - (name . guix-package-list-get-name) - (synopsis . guix-list-get-one-line) - (description . guix-list-get-one-line)) - (generation - (current . guix-generation-list-get-current) - (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: +(defun guix-list-describe (&optional mark-names) + "Describe entries marked with a general mark. +'Describe' means display entries in 'info' buffer. +If no entries are marked, describe the current entry. +With prefix argument, describe entries marked with any mark." + (interactive (list (unless current-prefix-arg '(general)))) + (let* ((ids (or (apply #'guix-list-get-marked-id-list mark-names) + (list (guix-list-current-id)))) + (count (length ids)) + (entry-type (guix-buffer-current-entry-type))) + (when (or (<= count (guix-list-describe-warning-count entry-type)) + (y-or-n-p (format "Do you really want to describe %d entries? " + count))) + (guix-list-describe-entries entry-type ids)))) - (ENTRY-TYPE . ((PARAM . FUN) ...)) + +;;; Wrappers for 'list' variables -PARAM is the name of an entry parameter of ENTRY-TYPE. +(defvar guix-list-data nil + "Alist with 'list' data. +This alist is filled by `guix-list-define-interface' macro.") -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-value (entry-type symbol) + "Return SYMBOL's value for ENTRY-TYPE from `guix-list-data'." + (symbol-value (guix-assq-value guix-list-data entry-type symbol))) -(defun guix-list-get-param-title (entry-type param) - "Return title of an ENTRY-TYPE entry parameter PARAM." - (or (guix-assq-value guix-list-column-titles - entry-type param) - (guix-get-param-title entry-type param))) +(defun guix-list-param-title (entry-type param) + "Return column title of an ENTRY-TYPE parameter PARAM." + (guix-buffer-param-title 'list entry-type param)) -(defun guix-list-get-column-format (entry-type) +(defun guix-list-format (entry-type) "Return column format for ENTRY-TYPE." - (guix-assq-value guix-list-column-format entry-type)) + (guix-list-value entry-type 'format)) + +(defun guix-list-displayed-params (entry-type) + "Return a list of ENTRY-TYPE parameters that should be displayed." + (mapcar #'car (guix-list-format entry-type))) -(defun guix-list-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-sort-key (entry-type) + "Return sort key for ENTRY-TYPE." + (guix-list-value entry-type 'sort-key)) -(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-additional-marks (entry-type) + "Return alist of additional marks for ENTRY-TYPE." + (guix-list-value entry-type 'marks)) + +(defun guix-list-single-entry? (entry-type) + "Return non-nil, if a single entry of ENTRY-TYPE should be listed." + (guix-list-value entry-type 'list-single)) + +(defun guix-list-describe-warning-count (entry-type) + "Return the maximum number of ENTRY-TYPE entries to describe." + (guix-list-value entry-type 'describe-count)) + +(defun guix-list-describe-entries (entry-type ids) + "Describe ENTRY-TYPE entries with IDS in 'info' buffer" + (funcall (guix-list-value entry-type 'describe) + ids)) + + +;;; Tabulated list internals (defun guix-list-sort-numerically (column a b) "Compare COLUMN of tabulated entries A and B numerically. -It is a sort predicate for `tabulated-list-format'. +This function is used for sort predicates for `tabulated-list-format'. Return non-nil, if B is bigger than A." (cl-flet ((num (entry) (string-to-number (aref (cadr entry) column)))) (> (num b) (num a)))) -(defun guix-list-make-tabulated-vector (entry-type fun) +(defmacro guix-list-define-numerical-sorter (column) + "Define numerical sort predicate for COLUMN. +See `guix-list-sort-numerically' for details." + (let ((name (intern (format "guix-list-sort-numerically-%d" column))) + (doc (format "\ +Predicate to sort tabulated list by column %d numerically. +See `guix-list-sort-numerically' for details." + column))) + `(defun ,name (a b) + ,doc + (guix-list-sort-numerically ,column a b)))) + +(defmacro guix-list-define-numerical-sorters (n) + "Define numerical sort predicates for columns from 0 to N. +See `guix-list-define-numerical-sorter' for details." + `(progn + ,@(mapcar (lambda (i) + `(guix-list-define-numerical-sorter ,i)) + (number-sequence 0 n)))) + +(guix-list-define-numerical-sorters 9) + +(defun guix-list-tabulated-sort-key (entry-type) + "Return ENTRY-TYPE sort key for `tabulated-list-sort-key'." + (let ((sort-key (guix-list-sort-key entry-type))) + (and sort-key + (cons (guix-list-param-title entry-type (car sort-key)) + (cdr sort-key))))) + +(defun guix-list-tabulated-vector (entry-type fun) "Call FUN on each column specification for ENTRY-TYPE. -FUN is called with 2 argument: parameter name and column -specification (see `guix-list-column-format'). +FUN is applied to column specification as arguments (see +`guix-list-format'). Return a vector made of values of FUN calls." (apply #'vector (mapcar (lambda (col-spec) - (funcall fun (car col-spec) (cdr col-spec))) - (guix-list-get-column-format entry-type)))) + (apply fun col-spec)) + (guix-list-format entry-type)))) -(defun guix-list-get-list-format (entry-type) +(defun guix-list-tabulated-format (entry-type) "Return ENTRY-TYPE list specification for `tabulated-list-format'." - (guix-list-make-tabulated-vector + (guix-list-tabulated-vector entry-type - (lambda (param spec) - (cons (guix-list-get-param-title entry-type param) - spec)))) + (lambda (param _ &rest rest-spec) + (cons (guix-list-param-title entry-type param) + rest-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'." +(defun guix-list-tabulated-entries (entries entry-type) + "Return a list of ENTRY-TYPE values for `tabulated-list-entries'." (mapcar (lambda (entry) - (list (guix-assq-value entry 'id) - (guix-list-get-tabulated-entry entry entry-type))) + (list (guix-entry-id entry) + (guix-list-tabulated-entry entry entry-type))) entries)) -(defun guix-list-get-tabulated-entry (entry entry-type) +(defun guix-list-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 +Parameters are taken from ENTRY-TYPE ENTRY." + (guix-list-tabulated-vector entry-type - (lambda (param _) - (let ((val (guix-assq-value entry param)) - (fun (guix-assq-value guix-list-column-value-methods - entry-type param))) + (lambda (param fun &rest _) + (let ((val (guix-entry-value entry param))) (if fun (funcall fun val entry) (guix-get-string val)))))) + +;;; Displaying entries + +(defun guix-list-get-display-entries (entry-type &rest args) + "Search for entries and show them in a 'list' buffer preferably." + (let ((entries (guix-buffer-get-entries 'list entry-type args))) + (if (or (null entries) ; = 0 + (cdr entries) ; > 1 + (guix-list-single-entry? entry-type) + (null (guix-buffer-value 'info entry-type 'show-entries))) + (guix-buffer-display-entries entries 'list entry-type args 'add) + (if (equal (guix-buffer-value 'info entry-type 'get-entries) + (guix-buffer-value 'list entry-type 'get-entries)) + (guix-buffer-display-entries entries 'info entry-type args 'add) + (guix-buffer-get-display-entries 'info entry-type args 'add))))) + +(defun guix-list-insert-entries (entries entry-type) + "Print ENTRY-TYPE ENTRIES in the current buffer." + (setq tabulated-list-entries + (guix-list-tabulated-entries entries entry-type)) + (tabulated-list-print)) + (defun guix-list-get-one-line (val &optional _) "Return one-line string from a multi-line string VAL. VAL may be nil." @@ -217,22 +222,18 @@ VAL may be nil." 'follow-link t 'help-echo "Find file")) + +;;; 'List' lines + (defun guix-list-current-id () - "Return ID of the current entry." + "Return ID of the entry at point." (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-current-package-id () - "Return ID of the current package." - (cl-ecase major-mode - (guix-package-list-mode - (guix-list-current-id)) - (guix-output-list-mode - (guix-assq-value (guix-list-current-entry) 'package-id)))) + "Return entry at point." + (guix-entry-by-id (guix-list-current-id) + (guix-buffer-current-entries))) (defun guix-list-for-each-line (fun &rest args) "Call FUN with ARGS for each entry line." @@ -263,20 +264,28 @@ 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'. +MARK-NAME is a symbol from `guix-list-marks'. ARGS is a list of additional values.") -(defvar guix-list-mark-alist +(defvar-local guix-list-marks nil + "Alist of available mark names and mark characters.") + +(defvar guix-list-default-marks '((empty . ?\s) (general . ?*)) - "Alist of available mark names and mark characters.") + "Alist of default mark names and mark characters.") + +(defun guix-list-marks (entry-type) + "Return alist of available marks for ENTRY-TYPE." + (append guix-list-default-marks + (guix-list-additional-marks entry-type))) -(defsubst guix-list-get-mark (name) +(defun guix-list-get-mark (name) "Return mark character by its NAME." - (or (guix-assq-value guix-list-mark-alist name) + (or (guix-assq-value guix-list-marks name) (error "Mark '%S' not found" name))) -(defsubst guix-list-get-mark-string (name) +(defun guix-list-get-mark-string (name) "Return mark string by its NAME." (string (guix-list-get-mark name))) @@ -288,11 +297,11 @@ ARGS is a list of additional values.") "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." +`guix-list-marks' except the `empty' one." (or mark-names (setq mark-names (delq 'empty - (mapcar #'car guix-list-mark-alist)))) + (mapcar #'car guix-list-marks)))) (cl-remove-if-not (lambda (assoc) (memq (cadr assoc) mark-names)) guix-list-marked)) @@ -314,7 +323,7 @@ See `guix-list-get-marked' for details." (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'. +MARK-NAME is a symbol from `guix-list-marks'. If ADVANCE is non-nil, move forward by one line after marking." (let ((id (guix-list-current-id))) (if (eq mark-name 'empty) @@ -337,7 +346,7 @@ With ARG, mark all lines." (defun guix-list-mark-all (&optional mark-name) "Mark all lines with MARK-NAME mark. -MARK-NAME is a symbol from `guix-list-mark-alist'. +MARK-NAME is a symbol from `guix-list-marks'. Interactively, put a general mark on all lines." (interactive) (or mark-name (setq mark-name 'general)) @@ -363,7 +372,7 @@ With ARG, unmark all lines." (guix-list-mark-all 'empty)) (defun guix-list-restore-marks () - "Put marks according to `guix-list-mark-alist'." + "Put marks according to `guix-list-marked'." (guix-list-for-each-line (lambda () (let ((mark-name (car (guix-assq-value guix-list-marked @@ -380,520 +389,183 @@ Same as `tabulated-list-sort', but also restore marks after sorting." (guix-list-restore-marks)) +;;; Major mode and interface definer + (defvar guix-list-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent - map (make-composed-keymap guix-root-map + map (make-composed-keymap guix-buffer-map tabulated-list-mode-map)) (define-key map (kbd "RET") 'guix-list-describe) + (define-key map (kbd "i") 'guix-list-describe) (define-key map (kbd "m") 'guix-list-mark) (define-key map (kbd "*") 'guix-list-mark) (define-key map (kbd "u") 'guix-list-unmark) (define-key map (kbd "DEL") 'guix-list-unmark-backward) (define-key map [remap tabulated-list-sort] 'guix-list-sort) map) - "Parent keymap for list buffers.") + "Keymap for `guix-list-mode' 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-mark-MARK-NAME' functions for each mark - specified in `:marks' argument." - (let* ((entry-type-str (symbol-name entry-type)) - (prefix (concat "guix-" entry-type-str "-list")) - (mode-str (concat prefix "-mode")) - (init-fun (intern (concat prefix "-mode-initialize"))) - (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 ,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) - -(defun guix-list-describe-maybe (entry-type ids) - "Describe ENTRY-TYPE entries in info buffer using list of IDS." - (let ((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))) - (apply #'guix-get-show-entries - guix-profile 'info entry-type 'id ids)))) - -(defun guix-list-describe (&optional arg) - "Describe entries marked with a general mark. -If no entries are marked, describe the current entry. -With prefix (if ARG is non-nil), describe entries marked with any mark." - (interactive "P") - (let ((ids (or (apply #'guix-list-get-marked-id-list - (unless arg '(general))) - (list (guix-list-current-id))))) - (guix-list-describe-maybe guix-entry-type ids))) - -(defun guix-list-edit-package () - "Go to the location of the current package." - (interactive) - (guix-edit (guix-list-current-package-id))) - - -;;; 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-installed - '((t :inherit guix-package-info-installed-outputs)) - "Face used if there are installed outputs for the current package." - :group 'guix-package-list-faces) - -(defface guix-package-list-obsolete - '((t :inherit guix-package-info-obsolete)) - "Face used if a package is obsolete." - :group 'guix-package-list-faces) - -(defcustom guix-package-list-generation-marking-enabled nil - "If non-nil, allow putting marks in a list with 'generation packages'. - -By default this is disabled, because it may be confusing. For -example a package is installed in some generation, so a user can -mark it for deletion in the list of packages from this -generation, but the package may not be installed in the latest -generation, so actually it cannot be deleted. - -If you managed to understand the explanation above or if you -really know what you do or if you just don't care, you can set -this variable to t. It should not do much harm anyway (most -likely)." - :type 'boolean - :group 'guix-package-list) - -(let ((map guix-package-list-mode-map)) - (define-key map (kbd "e") 'guix-list-edit-package) - (define-key map (kbd "x") 'guix-package-list-execute) - (define-key map (kbd "i") 'guix-package-list-mark-install) - (define-key map (kbd "d") 'guix-package-list-mark-delete) - (define-key map (kbd "U") 'guix-package-list-mark-upgrade) - (define-key map (kbd "^") 'guix-package-list-mark-upgrades)) - -(defun guix-package-list-get-name (name entry) - "Return NAME of the package ENTRY. -Colorize it with `guix-package-list-installed' or -`guix-package-list-obsolete' if needed." - (guix-get-string name - (cond ((guix-assq-value entry 'obsolete) - 'guix-package-list-obsolete) - ((guix-assq-value entry 'installed) - 'guix-package-list-installed)))) - -(defun guix-package-list-get-installed-outputs (installed &optional _) - "Return string with outputs from INSTALLED entries." - (guix-get-string - (mapcar (lambda (entry) - (guix-assq-value entry 'output)) - installed))) - -(defun guix-package-list-marking-check () - "Signal an error if marking is disabled for the current buffer." - (when (and (not guix-package-list-generation-marking-enabled) - (or (derived-mode-p 'guix-package-list-mode) - (derived-mode-p 'guix-output-list-mode)) - (eq guix-search-type 'generation)) - (error "Action marks are disabled for lists of 'generation packages'"))) - -(defun guix-package-list-mark-outputs (mark default - &optional prompt available) - "Mark the current package with MARK and move to the next line. -If PROMPT is non-nil, use it to ask a user for outputs from -AVAILABLE list, otherwise mark all DEFAULT outputs." - (let ((outputs (if prompt - (guix-completing-read-multiple - prompt available nil t) - default))) - (apply #'guix-list--mark mark t outputs))) - -(defun guix-package-list-mark-install (&optional arg) - "Mark the current package for installation and move to the next line. -With ARG, prompt for the outputs to install (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (all (guix-assq-value entry 'outputs)) - (installed (guix-get-installed-outputs entry)) - (available (cl-set-difference all installed :test #'string=))) - (or available - (user-error "This package is already installed")) - (guix-package-list-mark-outputs - 'install '("out") - (and arg "Output(s) to install: ") - available))) - -(defun guix-package-list-mark-delete (&optional arg) - "Mark the current package for deletion and move to the next line. -With ARG, prompt for the outputs to delete (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-get-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (guix-package-list-mark-outputs - 'delete installed - (and arg "Output(s) to delete: ") - installed))) - -(defun guix-package-list-mark-upgrade (&optional arg) - "Mark the current package for upgrading and move to the next line. -With ARG, prompt for the outputs to upgrade (several outputs may -be separated with \",\")." - (interactive "P") - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-get-installed-outputs entry))) - (or installed - (user-error "This package is not installed")) - (when (or (guix-assq-value entry 'obsolete) - (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) - (guix-package-list-mark-outputs - 'upgrade installed - (and arg "Output(s) to upgrade: ") - installed)))) - -(defun guix-list-mark-package-upgrades (fun) - "Mark all obsolete packages for upgrading. -Use FUN to perform marking of the current line. FUN should -accept an entry as argument." - (guix-package-list-marking-check) - (let ((obsolete (cl-remove-if-not - (lambda (entry) - (guix-assq-value entry 'obsolete)) - guix-entries))) - (guix-list-for-each-line - (lambda () - (let* ((id (guix-list-current-id)) - (entry (cl-find-if - (lambda (entry) - (equal id (guix-assq-value entry 'id))) - obsolete))) - (when entry - (funcall fun entry))))))) - -(defun guix-package-list-mark-upgrades () - "Mark all obsolete packages for upgrading." - (interactive) - (guix-list-mark-package-upgrades - (lambda (entry) - (apply #'guix-list--mark - 'upgrade nil - (guix-get-installed-outputs entry))))) - -(defun guix-list-execute-package-actions (fun) - "Perform actions on the marked packages. -Use FUN to define actions suitable for `guix-process-package-actions'. -FUN should accept action-type as argument." - (let ((actions (delq nil - (mapcar fun '(install delete upgrade))))) - (if actions - (guix-process-package-actions - guix-profile actions (current-buffer)) - (user-error "No operations specified")))) - -(defun guix-package-list-execute () - "Perform actions on the marked packages." - (interactive) - (guix-list-execute-package-actions #'guix-package-list-make-action)) + "Parent mode for displaying data in 'list' form.") + +(defun guix-list-mode-initialize (entry-type) + "Set up the current 'list' buffer for displaying ENTRY-TYPE entries." + (setq tabulated-list-padding 2 + tabulated-list-format (guix-list-tabulated-format entry-type) + tabulated-list-sort-key (guix-list-tabulated-sort-key entry-type)) + (setq-local guix-list-marks (guix-list-marks entry-type)) + (tabulated-list-init-header)) + +(defmacro guix-list-define-interface (entry-type &rest args) + "Define 'list' interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Required keywords: + + - `:format' - default value of the generated + `guix-ENTRY-TYPE-list-format' variable. + +Optional keywords: + + - `:sort-key' - default value of the generated + `guix-ENTRY-TYPE-list-sort-key' variable. + + - `:describe-function' - default value of the generated + `guix-ENTRY-TYPE-describe-function' variable. + + - `:list-single?' - default value of the generated + `guix-ENTRY-TYPE-list-single' variable. + + - `:marks' - default value of the generated + `guix-ENTRY-TYPE-list-marks' variable. + +The rest keyword arguments are passed to +`guix-buffer-define-interface' macro." + (declare (indent 1)) + (let* ((entry-type-str (symbol-name entry-type)) + (prefix (concat "guix-" entry-type-str "-list")) + (group (intern prefix)) + (describe-var (intern (concat prefix "-describe-function"))) + (describe-count-var (intern (concat prefix + "-describe-warning-count"))) + (format-var (intern (concat prefix "-format"))) + (sort-key-var (intern (concat prefix "-sort-key"))) + (list-single-var (intern (concat prefix "-single"))) + (marks-var (intern (concat prefix "-marks")))) + (guix-keyword-args-let args + ((show-entries-val :show-entries-function) + (describe-val :describe-function) + (describe-count-val :describe-count 10) + (format-val :format) + (sort-key-val :sort-key) + (list-single-val :list-single?) + (marks-val :marks)) + `(progn + (defcustom ,format-var ,format-val + ,(format "\ +List of format values of the displayed columns. +Each element of the list has a form: -(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)))) + (PARAM VALUE-FUN WIDTH SORT . PROPS) + +PARAM is a name of '%s' entry parameter. + +VALUE-FUN may be either nil or a function returning a value that +will be inserted. The function is called with 2 arguments: the +first one is the value of the parameter; the second one is an +entry (alist of parameter names and values). + +For the meaning of WIDTH, SORT and PROPS, see +`tabulated-list-format'." + entry-type-str) + :type 'sexp + :group ',group) + + (defcustom ,sort-key-var ,sort-key-val + ,(format "\ +Default sort key for 'list' buffer with '%s' entries. +Should be nil (no sort) or have a form: + + (PARAM . FLIP) + +PARAM is the name of '%s' entry parameter. For the meaning of +FLIP, see `tabulated-list-sort-key'." + entry-type-str entry-type-str) + :type '(choice (const :tag "No sort" nil) + (cons symbol boolean)) + :group ',group) + + (defvar ,marks-var ,marks-val + ,(format "\ +Alist of additional marks for 'list' buffer with '%s' entries. +Marks from this list are used along with `guix-list-default-marks'." + entry-type-str)) + + (defcustom ,list-single-var ,list-single-val + ,(format "\ +If non-nil, list '%s' entry even if it is the only matching result. +If nil, show a single '%s' entry in the 'info' buffer." + entry-type-str entry-type-str) + :type 'boolean + :group ',group) + + (defcustom ,describe-count-var ,describe-count-val + ,(format "\ +The maximum number of '%s' entries to describe without a warning. +If a user wants to describe more than this number of marked +entries, he will be prompted for confirmation. +See also `guix-list-describe'." + entry-type-str) + :type 'integer + :group ',group) + + (defvar ,describe-var ,describe-val + ,(format "Function used to describe '%s' entries." + entry-type-str)) + + (guix-alist-put! + '((describe . ,describe-var) + (describe-count . ,describe-count-var) + (format . ,format-var) + (sort-key . ,sort-key-var) + (list-single . ,list-single-var) + (marks . ,marks-var)) + 'guix-list-data ',entry-type) + + ,(if show-entries-val + `(guix-buffer-define-interface list ,entry-type + :show-entries-function ,show-entries-val + ,@%foreign-args) + + (let ((insert-fun (intern (concat prefix "-insert-entries"))) + (mode-init-fun (intern (concat prefix "-mode-initialize")))) + `(progn + (defun ,insert-fun (entries) + ,(format "\ +Print '%s' ENTRIES in the current 'list' buffer." + entry-type-str) + (guix-list-insert-entries entries ',entry-type)) + + (defun ,mode-init-fun () + ,(format "\ +Set up the current 'list' buffer for displaying '%s' entries." + entry-type-str) + (guix-list-mode-initialize ',entry-type)) + + (guix-buffer-define-interface list ,entry-type + :insert-entries-function ',insert-fun + :mode-init-function ',mode-init-fun + ,@%foreign-args)))))))) -;;; Displaying outputs - -(guix-define-buffer-type list output - :buffer-name "*Guix Package List*" - :required (package-id)) - -(guix-list-define-entry-type output - :sort-key name - :marks ((install . ?I) - (upgrade . ?U) - (delete . ?D))) - -(let ((map guix-output-list-mode-map)) - (define-key map (kbd "RET") 'guix-output-list-describe) - (define-key map (kbd "e") 'guix-list-edit-package) - (define-key map (kbd "x") 'guix-output-list-execute) - (define-key map (kbd "i") 'guix-output-list-mark-install) - (define-key map (kbd "d") 'guix-output-list-mark-delete) - (define-key map (kbd "U") 'guix-output-list-mark-upgrade) - (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) - -(defun guix-output-list-mark-install () - "Mark the current output for installation and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-assq-value entry 'installed))) - (if installed - (user-error "This output is already installed") - (guix-list--mark 'install t)))) - -(defun guix-output-list-mark-delete () - "Mark the current output for deletion and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-assq-value entry 'installed))) - (if installed - (guix-list--mark 'delete t) - (user-error "This output is not installed")))) - -(defun guix-output-list-mark-upgrade () - "Mark the current output for deletion and move to the next line." - (interactive) - (guix-package-list-marking-check) - (let* ((entry (guix-list-current-entry)) - (installed (guix-assq-value entry 'installed))) - (or installed - (user-error "This output is not installed")) - (when (or (guix-assq-value entry 'obsolete) - (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) - (guix-list--mark 'upgrade t)))) - -(defun guix-output-list-mark-upgrades () - "Mark all obsolete package outputs for upgrading." - (interactive) - (guix-list-mark-package-upgrades - (lambda (_) (guix-list--mark 'upgrade)))) - -(defun guix-output-list-execute () - "Perform actions on the marked outputs." - (interactive) - (guix-list-execute-package-actions #'guix-output-list-make-action)) - -(defun guix-output-list-make-action (action-type) - "Return action specification for the outputs marked with ACTION-TYPE. -Return nil, if there are no outputs marked with ACTION-TYPE. -The specification is suitable for `guix-process-output-actions'." - (let ((ids (guix-list-get-marked-id-list action-type))) - (and ids (cons action-type - (mapcar #'guix-get-package-id-and-output-by-output-id - ids))))) - -(defun guix-output-list-describe (&optional arg) - "Describe outputs or packages marked with a general mark. -If no entries are marked, describe the current output or package. -With prefix (if ARG is non-nil), describe entries marked with any mark. -Also see `guix-package-info-type'." - (interactive "P") - (if (eq guix-package-info-type 'output) - (guix-list-describe arg) - (let* ((oids (or (apply #'guix-list-get-marked-id-list - (unless arg '(general))) - (list (guix-list-current-id)))) - (pids (mapcar (lambda (oid) - (car (guix-get-package-id-and-output-by-output-id - oid))) - oids))) - (guix-list-describe-maybe 'package (cl-remove-duplicates pids))))) +(defvar guix-list-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group "guix-list-define-interface") + symbol-end) + . 1)))) - -;;; 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 "+") 'guix-generation-list-show-added-packages) - (define-key map (kbd "-") 'guix-generation-list-show-removed-packages) - (define-key map (kbd "=") 'guix-generation-list-diff) - (define-key map (kbd "D") 'guix-generation-list-diff) - (define-key map (kbd "e") 'guix-generation-list-ediff) - (define-key map (kbd "x") 'guix-generation-list-execute) - (define-key map (kbd "i") 'guix-list-describe) - (define-key map (kbd "s") 'guix-generation-list-switch) - (define-key map (kbd "d") 'guix-generation-list-mark-delete)) - -(defun guix-generation-list-get-current (val &optional _) - "Return string from VAL showing whether this generation is current. -VAL is a boolean value." - (if val "(current)" "")) - -(defun guix-generation-list-switch () - "Switch current profile to the generation at point." - (interactive) - (let* ((entry (guix-list-current-entry)) - (current (guix-assq-value entry 'current)) - (number (guix-assq-value entry 'number))) - (if current - (user-error "This generation is already the current one") - (guix-switch-to-generation guix-profile number (current-buffer))))) - -(defun guix-generation-list-show-packages () - "List installed packages for the generation at point." - (interactive) - (guix-get-show-entries guix-profile 'list guix-package-list-type - 'generation (guix-list-current-id))) - -(defun guix-generation-list-generations-to-compare () - "Return a sorted list of 2 marked generations for comparing." - (let ((numbers (guix-list-get-marked-id-list 'general))) - (if (/= (length numbers) 2) - (user-error "2 generations should be marked for comparing") - (sort numbers #'<)))) - -(defun guix-generation-list-show-added-packages () - "List package outputs added to the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs installed in the latest marked generation that were not -installed in the other one." - (interactive) - (apply #'guix-get-show-entries - guix-profile 'list 'output 'generation-diff - (reverse (guix-generation-list-generations-to-compare)))) - -(defun guix-generation-list-show-removed-packages () - "List package outputs removed from the latest marked generation. -If 2 generations are marked with \\[guix-list-mark], display -outputs not installed in the latest marked generation that were -installed in the other one." - (interactive) - (apply #'guix-get-show-entries - guix-profile 'list 'output 'generation-diff - (guix-generation-list-generations-to-compare))) - -(defun guix-generation-list-compare (diff-fun gen-fun) - "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results." - (cl-multiple-value-bind (gen1 gen2) - (guix-generation-list-generations-to-compare) - (funcall diff-fun - (funcall gen-fun gen1) - (funcall gen-fun gen2)))) - -(defun guix-generation-list-ediff-manifests () - "Run Ediff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-files - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-diff-manifests () - "Run Diff on manifests of the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-manifest-file)) - -(defun guix-generation-list-ediff-packages () - "Run Ediff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'ediff-buffers - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-diff-packages () - "Run Diff on package outputs installed in the 2 marked generations." - (interactive) - (guix-generation-list-compare - #'guix-diff - #'guix-profile-generation-packages-buffer)) - -(defun guix-generation-list-ediff (arg) - "Run Ediff on package outputs installed in the 2 marked generations. -With ARG, run Ediff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-ediff-manifests) - (guix-generation-list-ediff-packages))) - -(defun guix-generation-list-diff (arg) - "Run Diff on package outputs installed in the 2 marked generations. -With ARG, run Diff on manifests of the marked generations." - (interactive "P") - (if arg - (guix-generation-list-diff-manifests) - (guix-generation-list-diff-packages))) - -(defun guix-generation-list-mark-delete (&optional arg) - "Mark the current generation for deletion and move to the next line. -With ARG, mark all generations for deletion." - (interactive "P") - (if arg - (guix-list-mark-all 'delete) - (guix-list--mark 'delete t))) - -(defun guix-generation-list-execute () - "Delete marked generations." - (interactive) - (let ((marked (guix-list-get-marked-id-list 'delete))) - (or marked - (user-error "No generations marked for deletion")) - (guix-delete-generations guix-profile marked (current-buffer)))) +(font-lock-add-keywords 'emacs-lisp-mode guix-list-font-lock-keywords) (provide 'guix-list) diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index 7175b103da..6f9eb422e0 100644 --- a/emacs/guix-main.scm +++ b/emacs/guix-main.scm @@ -58,7 +58,6 @@ (guix licenses) (guix utils) (guix ui) - (guix scripts graph) (guix scripts lint) (guix scripts package) (guix scripts pull) @@ -989,7 +988,8 @@ Return #t if the shell command was executed successfully." (define (graph-type-names) "Return a list of names of available graph node types." - (map node-type-name %node-types)) + (map (@ (guix graph) node-type-name) + (@ (guix scripts graph) %node-types))) (define (refresh-updater-names) "Return a list of names of available refresh updater types." diff --git a/emacs/guix-messages.el b/emacs/guix-messages.el index 2bf99de6fa..eb2a76e216 100644 --- a/emacs/guix-messages.el +++ b/emacs/guix-messages.el @@ -31,9 +31,8 @@ (defvar guix-messages `((package (id - (0 "Packages not found.") - (1 "") - (many "%d packages." count)) + ,(lambda (_ entries ids) + (guix-message-packages-by-id entries 'package ids))) (name ,(lambda (_ entries names) (guix-message-packages-by-name entries 'package names))) @@ -67,9 +66,8 @@ (output (id - (0 "Package outputs not found.") - (1 "") - (many "%d package outputs." count)) + ,(lambda (_ entries ids) + (guix-message-packages-by-id entries 'output ids))) (name ,(lambda (_ entries names) (guix-message-packages-by-name entries 'output names))) @@ -147,6 +145,22 @@ (guix-message-string-entry-type entry-type 'plural))))) +(defun guix-message-packages-by-id (entries entry-type ids) + "Display a message for packages or outputs searched by IDS." + (let* ((count (length entries)) + (str-beg (guix-message-string-entries count entry-type)) + (str-end (if (> count 1) + (concat "with the following IDs: " + (mapconcat #'guix-get-string ids ", ")) + (concat "with ID " (guix-get-string (car ids)))))) + (if (zerop count) + (message "%s %s. +Most likely, Guix REPL was restarted, so IDs are not actual +anymore, because they live only during the REPL process. +Try \"M-x guix-search-by-name\"." + str-beg str-end) + (message "%s %s." str-beg str-end)))) + (defun guix-message-packages-by-name (entries entry-type names) "Display a message for packages or outputs searched by NAMES." (let* ((count (length entries)) diff --git a/emacs/guix-read.el b/emacs/guix-read.el index e60af9c2f7..3bc7b16587 100644 --- a/emacs/guix-read.el +++ b/emacs/guix-read.el @@ -26,95 +26,40 @@ (require 'guix-help-vars) (require 'guix-utils) -(require 'guix-base) - -(defun guix-read-file-name (prompt &optional dir default-filename - mustmatch initial predicate) - "Read file name. -This function is similar to `read-file-name' except it also -expands the file name." - (expand-file-name (read-file-name prompt dir default-filename - mustmatch initial predicate))) - -(defmacro guix-define-reader (name read-fun completions prompt) - "Define NAME function to read from minibuffer. -READ-FUN may be `completing-read', `completing-read-multiple' or -another function with the same arguments." - `(defun ,name (&optional prompt initial-contents) - (,read-fun ,(if prompt - `(or prompt ,prompt) - 'prompt) - ,completions nil nil initial-contents))) - -(defmacro guix-define-readers (&rest args) - "Define reader functions. - -ARGS should have a form [KEYWORD VALUE] ... The following -keywords are available: - - - `completions-var' - variable used to get completions. - - - `completions-getter' - function used to get completions. - - - `single-reader', `single-prompt' - name of a function to read - a single value, and a prompt for it. - - - `multiple-reader', `multiple-prompt' - name of a function to - read multiple values, and a prompt for it. - - - `multiple-separator' - if specified, another - `<multiple-reader-name>-string' function returning a string - of multiple values separated the specified separator will be - defined." - (let (completions-var - completions-getter - single-reader - single-prompt - multiple-reader - multiple-prompt - multiple-separator) - - ;; Process the keyword args. - (while (keywordp (car args)) - (pcase (pop args) - (`:completions-var (setq completions-var (pop args))) - (`:completions-getter (setq completions-getter (pop args))) - (`:single-reader (setq single-reader (pop args))) - (`:single-prompt (setq single-prompt (pop args))) - (`:multiple-reader (setq multiple-reader (pop args))) - (`:multiple-prompt (setq multiple-prompt (pop args))) - (`:multiple-separator (setq multiple-separator (pop args))) - (_ (pop args)))) - - (let ((completions - (cond ((and completions-var completions-getter) - `(or ,completions-var - (setq ,completions-var - (funcall ',completions-getter)))) - (completions-var - completions-var) - (completions-getter - `(funcall ',completions-getter))))) - `(progn - ,(when (and completions-var - (not (boundp completions-var))) - `(defvar ,completions-var nil)) - - ,(when single-reader - `(guix-define-reader ,single-reader completing-read - ,completions ,single-prompt)) - - ,(when multiple-reader - `(guix-define-reader ,multiple-reader completing-read-multiple - ,completions ,multiple-prompt)) - - ,(when (and multiple-reader multiple-separator) - (let ((name (intern (concat (symbol-name multiple-reader) - "-string")))) - `(defun ,name (&optional prompt initial-contents) - (guix-concat-strings - (,multiple-reader prompt initial-contents) - ,multiple-separator)))))))) +(require 'guix-backend) +(require 'guix-guile) + + +;;; Receivable lists of packages, lint checkers, etc. + +(guix-memoized-defun guix-graph-type-names () + "Return a list of names of available graph node types." + (guix-eval-read (guix-make-guile-expression 'graph-type-names))) + +(guix-memoized-defun guix-refresh-updater-names () + "Return a list of names of available refresh updater types." + (guix-eval-read (guix-make-guile-expression 'refresh-updater-names))) + +(guix-memoized-defun guix-lint-checker-names () + "Return a list of names of available lint checkers." + (guix-eval-read (guix-make-guile-expression 'lint-checker-names))) + +(guix-memoized-defun guix-package-names () + "Return a list of names of available packages." + (sort + ;; Work around <https://github.com/jaor/geiser/issues/64>: + ;; list of strings is parsed much slower than list of lists, + ;; so we use 'package-names-lists' instead of 'package-names'. + + ;; (guix-eval-read (guix-make-guile-expression 'package-names)) + + (mapcar #'car + (guix-eval-read (guix-make-guile-expression + 'package-names-lists))) + #'string<)) + + +;;; Readers (guix-define-readers :completions-var guix-help-system-types diff --git a/emacs/guix-ui-generation.el b/emacs/guix-ui-generation.el new file mode 100644 index 0000000000..aa71645b4e --- /dev/null +++ b/emacs/guix-ui-generation.el @@ -0,0 +1,433 @@ +;;; guix-ui-generation.el --- Interface for displaying generations -*- lexical-binding: t -*- + +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides an interface for displaying profile generations in +;; 'list' and 'info' buffers, and commands for working with them. + +;;; Code: + +(require 'cl-lib) +(require 'guix-buffer) +(require 'guix-list) +(require 'guix-info) +(require 'guix-ui) +(require 'guix-ui-package) +(require 'guix-base) +(require 'guix-backend) +(require 'guix-guile) +(require 'guix-entry) +(require 'guix-utils) + +(guix-ui-define-entry-type generation) + +(defun guix-generation-get-display (profile search-type &rest search-values) + "Search for generations and show results. + +If PROFILE is nil, use `guix-current-profile'. + +See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and +SEARCH-VALUES." + (apply #'guix-list-get-display-entries + 'generation + (or profile guix-current-profile) + search-type search-values)) + +(defun guix-delete-generations (profile generations + &optional operation-buffer) + "Delete GENERATIONS from PROFILE. +Each element from GENERATIONS is a generation number." + (when (or (not guix-operation-confirm) + (y-or-n-p + (let ((count (length generations))) + (if (> count 1) + (format "Delete %d generations from profile '%s'? " + count profile) + (format "Delete generation %d from profile '%s'? " + (car generations) profile))))) + (guix-eval-in-repl + (guix-make-guile-expression + 'delete-generations* profile generations) + operation-buffer))) + +(defun guix-switch-to-generation (profile generation + &optional operation-buffer) + "Switch PROFILE to GENERATION." + (when (or (not guix-operation-confirm) + (y-or-n-p (format "Switch profile '%s' to generation %d? " + profile generation))) + (guix-eval-in-repl + (guix-make-guile-expression + 'switch-to-generation* profile generation) + operation-buffer))) + + +;;; Generation 'info' + +(guix-ui-info-define-interface generation + :buffer-name "*Guix Generation Info*" + :format '((number format guix-generation-info-insert-number) + (prev-number format (format)) + (current format guix-generation-info-insert-current) + (path simple (indent guix-file)) + (time format (time))) + :titles '((path . "File name") + (prev-number . "Previous number"))) + +(defface guix-generation-info-number + '((t :inherit font-lock-keyword-face)) + "Face used for a number of a generation." + :group 'guix-generation-info-faces) + +(defface guix-generation-info-current + '((t :inherit guix-package-info-installed-outputs)) + "Face used if a generation is the current one." + :group 'guix-generation-info-faces) + +(defface guix-generation-info-not-current + '((t nil)) + "Face used if a generation is not the current one." + :group 'guix-generation-info-faces) + +(defun guix-generation-info-insert-number (number &optional _) + "Insert generation NUMBER and action buttons." + (guix-info-insert-value-format number 'guix-generation-info-number) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Packages" + (lambda (btn) + (guix-buffer-get-display-entries + 'list guix-package-list-type + (list (guix-ui-current-profile) + 'generation (button-get btn 'number)) + 'add)) + "Show installed packages for this generation" + 'number number) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Delete" + (lambda (btn) + (guix-delete-generations (guix-ui-current-profile) + (list (button-get btn 'number)) + (current-buffer))) + "Delete this generation" + 'number number)) + +(defun guix-generation-info-insert-current (val entry) + "Insert boolean value VAL showing whether this generation is current." + (if val + (guix-info-insert-value-format "Yes" 'guix-generation-info-current) + (guix-info-insert-value-format "No" 'guix-generation-info-not-current) + (guix-info-insert-indent) + (guix-info-insert-action-button + "Switch" + (lambda (btn) + (guix-switch-to-generation (guix-ui-current-profile) + (button-get btn 'number) + (current-buffer))) + "Switch to this generation (make it the current one)" + 'number (guix-entry-value entry 'number)))) + + +;;; Generation 'list' + +(guix-ui-list-define-interface generation + :buffer-name "*Guix Generation List*" + :format '((number nil 5 guix-list-sort-numerically-0 :right-align t) + (current guix-generation-list-get-current 10 t) + (time guix-list-get-time 20 t) + (path guix-list-get-file-path 30 t)) + :titles '((number . "N.")) + :sort-key '(number . t) + :marks '((delete . ?D))) + +(let ((map guix-generation-list-mode-map)) + (define-key map (kbd "RET") 'guix-generation-list-show-packages) + (define-key map (kbd "+") 'guix-generation-list-show-added-packages) + (define-key map (kbd "-") 'guix-generation-list-show-removed-packages) + (define-key map (kbd "=") 'guix-generation-list-diff) + (define-key map (kbd "D") 'guix-generation-list-diff) + (define-key map (kbd "e") 'guix-generation-list-ediff) + (define-key map (kbd "x") 'guix-generation-list-execute) + (define-key map (kbd "s") 'guix-generation-list-switch) + (define-key map (kbd "c") 'guix-generation-list-switch) + (define-key map (kbd "d") 'guix-generation-list-mark-delete)) + +(defun guix-generation-list-get-current (val &optional _) + "Return string from VAL showing whether this generation is current. +VAL is a boolean value." + (if val "(current)" "")) + +(defun guix-generation-list-switch () + "Switch current profile to the generation at point." + (interactive) + (let* ((entry (guix-list-current-entry)) + (current (guix-entry-value entry 'current)) + (number (guix-entry-value entry 'number))) + (if current + (user-error "This generation is already the current one") + (guix-switch-to-generation (guix-ui-current-profile) + number (current-buffer))))) + +(defun guix-generation-list-show-packages () + "List installed packages for the generation at point." + (interactive) + (guix-package-get-display + (guix-ui-current-profile) + 'generation (guix-list-current-id))) + +(defun guix-generation-list-generations-to-compare () + "Return a sorted list of 2 marked generations for comparing." + (let ((numbers (guix-list-get-marked-id-list 'general))) + (if (/= (length numbers) 2) + (user-error "2 generations should be marked for comparing") + (sort numbers #'<)))) + +(defun guix-generation-list-show-added-packages () + "List package outputs added to the latest marked generation. +If 2 generations are marked with \\[guix-list-mark], display +outputs installed in the latest marked generation that were not +installed in the other one." + (interactive) + (guix-buffer-get-display-entries + 'list 'output + (cl-list* (guix-ui-current-profile) + 'generation-diff + (reverse (guix-generation-list-generations-to-compare))) + 'add)) + +(defun guix-generation-list-show-removed-packages () + "List package outputs removed from the latest marked generation. +If 2 generations are marked with \\[guix-list-mark], display +outputs not installed in the latest marked generation that were +installed in the other one." + (interactive) + (guix-buffer-get-display-entries + 'list 'output + (cl-list* (guix-ui-current-profile) + 'generation-diff + (guix-generation-list-generations-to-compare)) + 'add)) + +(defun guix-generation-list-compare (diff-fun gen-fun) + "Run GEN-FUN on the 2 marked generations and run DIFF-FUN on the results." + (cl-multiple-value-bind (gen1 gen2) + (guix-generation-list-generations-to-compare) + (funcall diff-fun + (funcall gen-fun gen1) + (funcall gen-fun gen2)))) + +(defun guix-generation-list-ediff-manifests () + "Run Ediff on manifests of the 2 marked generations." + (interactive) + (guix-generation-list-compare + #'ediff-files + #'guix-profile-generation-manifest-file)) + +(defun guix-generation-list-diff-manifests () + "Run Diff on manifests of the 2 marked generations." + (interactive) + (guix-generation-list-compare + #'guix-diff + #'guix-profile-generation-manifest-file)) + +(defun guix-generation-list-ediff-packages () + "Run Ediff on package outputs installed in the 2 marked generations." + (interactive) + (guix-generation-list-compare + #'ediff-buffers + #'guix-profile-generation-packages-buffer)) + +(defun guix-generation-list-diff-packages () + "Run Diff on package outputs installed in the 2 marked generations." + (interactive) + (guix-generation-list-compare + #'guix-diff + #'guix-profile-generation-packages-buffer)) + +(defun guix-generation-list-ediff (arg) + "Run Ediff on package outputs installed in the 2 marked generations. +With ARG, run Ediff on manifests of the marked generations." + (interactive "P") + (if arg + (guix-generation-list-ediff-manifests) + (guix-generation-list-ediff-packages))) + +(defun guix-generation-list-diff (arg) + "Run Diff on package outputs installed in the 2 marked generations. +With ARG, run Diff on manifests of the marked generations." + (interactive "P") + (if arg + (guix-generation-list-diff-manifests) + (guix-generation-list-diff-packages))) + +(defun guix-generation-list-mark-delete (&optional arg) + "Mark the current generation for deletion and move to the next line. +With ARG, mark all generations for deletion." + (interactive "P") + (if arg + (guix-list-mark-all 'delete) + (guix-list--mark 'delete t))) + +(defun guix-generation-list-execute () + "Delete marked generations." + (interactive) + (let ((marked (guix-list-get-marked-id-list 'delete))) + (or marked + (user-error "No generations marked for deletion")) + (guix-delete-generations (guix-ui-current-profile) + marked (current-buffer)))) + + +;;; Inserting packages to compare generations + +(defcustom guix-generation-packages-buffer-name-function + #'guix-generation-packages-buffer-name-default + "Function used to define name of a buffer with generation packages. +This function is called with 2 arguments: PROFILE (string) and +GENERATION (number)." + :type '(choice (function-item guix-generation-packages-buffer-name-default) + (function-item guix-generation-packages-buffer-name-long) + (function :tag "Other function")) + :group 'guix-generation) + +(defcustom guix-generation-packages-update-buffer t + "If non-nil, always update list of packages during comparing generations. +If nil, generation packages are received only once. So when you +compare generation 1 and generation 2, the packages for both +generations will be received. Then if you compare generation 1 +and generation 3, only the packages for generation 3 will be +received. Thus if you use comparing of different generations a +lot, you may set this variable to nil to improve the +performance." + :type 'boolean + :group 'guix-generation) + +(defvar guix-generation-output-name-width 30 + "Width of an output name \"column\". +This variable is used in auxiliary buffers for comparing generations.") + +(defun guix-generation-packages (profile generation) + "Return a list of sorted packages installed in PROFILE's GENERATION. +Each element of the list is a list of the package specification +and its store path." + (let ((names+paths (guix-eval-read + (guix-make-guile-expression + 'generation-package-specifications+paths + profile generation)))) + (sort names+paths + (lambda (a b) + (string< (car a) (car b)))))) + +(defun guix-generation-packages-buffer-name-default (profile generation) + "Return name of a buffer for displaying GENERATION's package outputs. +Use base name of PROFILE file name." + (let ((profile-name (file-name-base (directory-file-name profile)))) + (format "*Guix %s: generation %s*" + profile-name generation))) + +(defun guix-generation-packages-buffer-name-long (profile generation) + "Return name of a buffer for displaying GENERATION's package outputs. +Use the full PROFILE file name." + (format "*Guix generation %s (%s)*" + generation profile)) + +(defun guix-generation-packages-buffer-name (profile generation) + "Return name of a buffer for displaying GENERATION's package outputs." + (funcall guix-generation-packages-buffer-name-function + profile generation)) + +(defun guix-generation-insert-package (name path) + "Insert package output NAME and store PATH at point." + (insert name) + (indent-to guix-generation-output-name-width 2) + (insert path "\n")) + +(defun guix-generation-insert-packages (buffer profile generation) + "Insert package outputs installed in PROFILE's GENERATION in BUFFER." + (with-current-buffer buffer + (setq buffer-read-only nil + indent-tabs-mode nil) + (erase-buffer) + (mapc (lambda (name+path) + (guix-generation-insert-package + (car name+path) (cadr name+path))) + (guix-generation-packages profile generation)))) + +(defun guix-generation-packages-buffer (profile generation) + "Return buffer with package outputs installed in PROFILE's GENERATION. +Create the buffer if needed." + (let ((buf-name (guix-generation-packages-buffer-name + profile generation))) + (or (and (null guix-generation-packages-update-buffer) + (get-buffer buf-name)) + (let ((buf (get-buffer-create buf-name))) + (guix-generation-insert-packages buf profile generation) + buf)))) + +(defun guix-profile-generation-manifest-file (generation) + "Return the file name of a GENERATION's manifest. +GENERATION is a generation number of the current profile." + (guix-manifest-file (guix-ui-current-profile) generation)) + +(defun guix-profile-generation-packages-buffer (generation) + "Insert GENERATION's package outputs in a buffer and return it. +GENERATION is a generation number of the current profile." + (guix-generation-packages-buffer (guix-ui-current-profile) + generation)) + + +;;; Interactive commands + +;;;###autoload +(defun guix-generations (&optional profile) + "Display information about all generations. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive (list (guix-ui-read-profile))) + (guix-generation-get-display profile 'all)) + +;;;###autoload +(defun guix-last-generations (number &optional profile) + "Display information about last NUMBER generations. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive + (list (read-number "The number of last generations: ") + (guix-ui-read-profile))) + (guix-generation-get-display profile 'last number)) + +;;;###autoload +(defun guix-generations-by-time (from to &optional profile) + "Display information about generations created between FROM and TO. +FROM and TO should be time values. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive + (list (guix-read-date "Find generations (from): ") + (guix-read-date "Find generations (to): ") + (guix-ui-read-profile))) + (guix-generation-get-display profile 'time + (float-time from) + (float-time to))) + +(provide 'guix-ui-generation) + +;;; guix-ui-generation.el ends here diff --git a/emacs/guix-ui-package.el b/emacs/guix-ui-package.el new file mode 100644 index 0000000000..e0c98eaed6 --- /dev/null +++ b/emacs/guix-ui-package.el @@ -0,0 +1,955 @@ +;;; guix-ui-package.el --- Interface for displaying packages -*- lexical-binding: t -*- + +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides an interface for displaying packages and outputs +;; in 'list' and 'info' buffers, and commands for working with them. + +;;; Code: + +(require 'cl-lib) +(require 'guix-buffer) +(require 'guix-list) +(require 'guix-info) +(require 'guix-ui) +(require 'guix-base) +(require 'guix-backend) +(require 'guix-guile) +(require 'guix-entry) +(require 'guix-utils) +(require 'guix-hydra-build) + +(guix-ui-define-entry-type package) +(guix-ui-define-entry-type output) + +(defcustom guix-package-list-type 'output + "Define how to display packages in 'list' buffer. +Should be a symbol `package' or `output' (if `output', display each +output on a separate line; if `package', display each package on +a separate line)." + :type '(choice (const :tag "List of packages" package) + (const :tag "List of outputs" output)) + :group 'guix-package) + +(defcustom guix-package-info-type 'package + "Define how to display packages in 'info' buffer. +Should be a symbol `package' or `output' (if `output', display +each output separately; if `package', display outputs inside +package data)." + :type '(choice (const :tag "Display packages" package) + (const :tag "Display outputs" output)) + :group 'guix-package) + +(defun guix-package-get-display (profile search-type &rest search-values) + "Search for packages/outputs and show results. + +If PROFILE is nil, use `guix-current-profile'. + +See `guix-ui-get-entries' for the meaning of SEARCH-TYPE and +SEARCH-VALUES. + +Results are displayed in the list buffer, unless a single package +is found and `guix-package-list-single' is nil." + (let* ((args (cl-list* (or profile guix-current-profile) + search-type search-values)) + (entries (guix-buffer-get-entries + 'list guix-package-list-type args))) + (if (or guix-package-list-single + (null entries) + (cdr entries)) + (guix-buffer-display-entries + entries 'list guix-package-list-type args 'add) + (guix-buffer-get-display-entries + 'info guix-package-info-type args 'add)))) + +(defun guix-package-entry->name-specification (entry &optional output) + "Return name specification of the package ENTRY and OUTPUT." + (guix-package-name-specification + (guix-entry-value entry 'name) + (guix-entry-value entry 'version) + (or output (guix-entry-value entry 'output)))) + +(defun guix-package-entries->name-specifications (entries) + "Return name specifications by the package or output ENTRIES." + (cl-remove-duplicates (mapcar #'guix-package-entry->name-specification + entries) + :test #'string=)) + +(defun guix-package-installed-outputs (entry) + "Return a list of installed outputs for the package ENTRY." + (mapcar (lambda (installed-entry) + (guix-entry-value installed-entry 'output)) + (guix-entry-value entry 'installed))) + +(defun guix-package-id-and-output-by-output-id (output-id) + "Return a list (PACKAGE-ID OUTPUT) by OUTPUT-ID." + (cl-multiple-value-bind (package-id-str output) + (split-string output-id ":") + (let ((package-id (string-to-number package-id-str))) + (list (if (= 0 package-id) package-id-str package-id) + output)))) + + +;;; Processing package actions + +(defun guix-process-package-actions (profile actions + &optional operation-buffer) + "Process package ACTIONS on PROFILE. +Each action is a list of the form: + + (ACTION-TYPE PACKAGE-SPEC ...) + +ACTION-TYPE is one of the following symbols: `install', +`upgrade', `remove'/`delete'. +PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." + (let (install upgrade remove) + (mapc (lambda (action) + (let ((action-type (car action)) + (specs (cdr action))) + (cl-case action-type + (install (setq install (append install specs))) + (upgrade (setq upgrade (append upgrade specs))) + ((remove delete) (setq remove (append remove specs)))))) + actions) + (when (guix-continue-package-operation-p + profile + :install install :upgrade upgrade :remove remove) + (guix-eval-in-repl + (guix-make-guile-expression + 'process-package-actions profile + :install install :upgrade upgrade :remove remove + :use-substitutes? (or guix-use-substitutes 'f) + :dry-run? (or guix-dry-run 'f)) + (and (not guix-dry-run) operation-buffer))))) + +(cl-defun guix-continue-package-operation-p (profile + &key install upgrade remove) + "Return non-nil if a package operation should be continued. +Ask a user if needed (see `guix-operation-confirm'). +INSTALL, UPGRADE, REMOVE are 'package action specifications'. +See `guix-process-package-actions' for details." + (or (null guix-operation-confirm) + (let* ((entries (guix-ui-get-entries + profile 'package 'id + (append (mapcar #'car install) + (mapcar #'car upgrade) + (mapcar #'car remove)) + '(id name version location))) + (install-strings (guix-get-package-strings install entries)) + (upgrade-strings (guix-get-package-strings upgrade entries)) + (remove-strings (guix-get-package-strings remove entries))) + (if (or install-strings upgrade-strings remove-strings) + (let ((buf (get-buffer-create guix-temp-buffer-name))) + (with-current-buffer buf + (setq-local cursor-type nil) + (setq buffer-read-only nil) + (erase-buffer) + (insert "Profile: " profile "\n\n") + (guix-insert-package-strings install-strings "install") + (guix-insert-package-strings upgrade-strings "upgrade") + (guix-insert-package-strings remove-strings "remove") + (let ((win (temp-buffer-window-show + buf + '((display-buffer-reuse-window + display-buffer-at-bottom) + (window-height . fit-window-to-buffer))))) + (prog1 (guix-operation-prompt) + (quit-window nil win))))) + (message "Nothing to be done. +If Guix REPL was restarted, the data is not up-to-date.") + nil)))) + +(defun guix-get-package-strings (specs entries) + "Return short package descriptions for performing package actions. +See `guix-process-package-actions' for the meaning of SPECS. +ENTRIES is a list of package entries to get info about packages." + (delq nil + (mapcar + (lambda (spec) + (let* ((id (car spec)) + (outputs (cdr spec)) + (entry (guix-entry-by-id id entries))) + (when entry + (let ((location (guix-entry-value entry 'location))) + (concat (guix-package-entry->name-specification entry) + (when outputs + (concat ":" + (guix-concat-strings outputs ","))) + (when location + (concat "\t(" location ")"))))))) + specs))) + +(defun guix-insert-package-strings (strings action) + "Insert information STRINGS at point for performing package ACTION." + (when strings + (insert "Package(s) to " (propertize action 'face 'bold) ":\n") + (mapc (lambda (str) + (insert " " str "\n")) + strings) + (insert "\n"))) + + +;;; Package 'info' + +(guix-ui-info-define-interface package + :buffer-name "*Guix Package Info*" + :format '(guix-package-info-insert-heading + ignore + (synopsis ignore (simple guix-package-info-synopsis)) + ignore + (description ignore (simple guix-package-info-description)) + ignore + (outputs simple guix-package-info-insert-outputs) + (source simple guix-package-info-insert-source) + (location format (format guix-package-location)) + (home-url format (format guix-url)) + (license format (format guix-package-info-license)) + (inputs format (format guix-package-input)) + (native-inputs format (format guix-package-native-input)) + (propagated-inputs format + (format guix-package-propagated-input))) + :titles '((home-url . "Home page")) + :required '(id name version installed non-unique)) + +(guix-info-define-interface installed-output + :format '((path simple (indent guix-file)) + (dependencies simple (indent guix-file))) + :titles '((path . "Store directory")) + :reduced? t) + +(defface guix-package-info-heading + '((t :inherit guix-info-heading)) + "Face for package name and version headings." + :group 'guix-package-info-faces) + +(defface guix-package-info-name + '((t :inherit font-lock-keyword-face)) + "Face used for a name of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-name-button + '((t :inherit button)) + "Face used for a full name that can be used to describe a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-version + '((t :inherit font-lock-builtin-face)) + "Face used for a version of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-synopsis + '((((type tty pc) (class color)) :weight bold) + (t :height 1.1 :weight bold :inherit variable-pitch)) + "Face used for a synopsis of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-description + '((t)) + "Face used for a description of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-license + '((t :inherit font-lock-string-face)) + "Face used for a license of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-location + '((t :inherit link)) + "Face used for a location of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-source + '((t :inherit link :underline nil)) + "Face used for a source URL of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-installed-outputs + '((default :weight bold) + (((class color) (min-colors 88) (background light)) + :foreground "ForestGreen") + (((class color) (min-colors 88) (background dark)) + :foreground "PaleGreen") + (((class color) (min-colors 8)) + :foreground "green") + (t :underline t)) + "Face used for installed outputs of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-uninstalled-outputs + '((t :weight bold)) + "Face used for uninstalled outputs of a package." + :group 'guix-package-info-faces) + +(defface guix-package-info-obsolete + '((t :inherit error)) + "Face used if a package is obsolete." + :group 'guix-package-info-faces) + +(defcustom guix-package-info-auto-find-source nil + "If non-nil, find a source file after pressing a \"Show\" button. +If nil, just display the source file path without finding." + :type 'boolean + :group 'guix-package-info) + +(defcustom guix-package-info-auto-download-source t + "If nil, do not automatically download a source file if it doesn't exist. +After pressing a \"Show\" button, a derivation of the package +source is calculated and a store file path is displayed. If this +variable is non-nil and the source file does not exist in the +store, it will be automatically downloaded (with a possible +prompt depending on `guix-operation-confirm' variable)." + :type 'boolean + :group 'guix-package-info) + +(defvar guix-package-info-download-buffer nil + "Buffer from which a current download operation was performed.") + +(defvar guix-package-info-output-format "%-10s" + "String used to format output names of the packages. +It should be a '%s'-sequence. After inserting an output name +formatted with this string, an action button is inserted.") + +(defvar guix-package-info-obsolete-string "(This package is obsolete)" + "String used if a package is obsolete.") + +(define-button-type 'guix-package-location + :supertype 'guix + 'face 'guix-package-info-location + 'help-echo "Find location of this package" + 'action (lambda (btn) + (guix-find-location (button-label btn)))) + +(define-button-type 'guix-package-name + :supertype 'guix + 'face 'guix-package-info-name-button + 'help-echo "Describe this package" + 'action (lambda (btn) + (guix-buffer-get-display-entries-current + 'info guix-package-info-type + (list (guix-ui-current-profile) + 'name (button-label btn)) + 'add))) + +(define-button-type 'guix-package-source + :supertype 'guix + 'face 'guix-package-info-source + 'help-echo "" + 'action (lambda (_) + ;; As a source may not be a real URL (e.g., "mirror://..."), + ;; no action is bound to a source button. + (message "Yes, this is the source URL. What did you expect?"))) + +(defun guix-package-info-insert-heading (entry) + "Insert package ENTRY heading (name specification) at point." + (guix-insert-button + (guix-package-entry->name-specification entry) + 'guix-package-name + 'face 'guix-package-info-heading)) + +(defmacro guix-package-info-define-insert-inputs (&optional type) + "Define a face and a function for inserting package inputs. +TYPE is a type of inputs. +Function name is `guix-package-info-insert-TYPE-inputs'. +Face name is `guix-package-info-TYPE-inputs'." + (let* ((type-str (symbol-name type)) + (type-name (and type (concat type-str "-"))) + (type-desc (and type (concat type-str " "))) + (face (intern (concat "guix-package-info-" type-name "inputs"))) + (btn (intern (concat "guix-package-" type-name "input")))) + `(progn + (defface ,face + '((t :inherit guix-package-info-name-button)) + ,(concat "Face used for " type-desc "inputs of a package.") + :group 'guix-package-info-faces) + + (define-button-type ',btn + :supertype 'guix-package-name + 'face ',face)))) + +(guix-package-info-define-insert-inputs) +(guix-package-info-define-insert-inputs native) +(guix-package-info-define-insert-inputs propagated) + +(defun guix-package-info-insert-outputs (outputs entry) + "Insert OUTPUTS from package ENTRY at point." + (and (guix-entry-value entry 'obsolete) + (guix-package-info-insert-obsolete-text)) + (and (guix-entry-value entry 'non-unique) + (guix-entry-value entry 'installed) + (guix-package-info-insert-non-unique-text + (guix-package-entry->name-specification entry))) + (insert "\n") + (dolist (output outputs) + (guix-package-info-insert-output output entry))) + +(defun guix-package-info-insert-obsolete-text () + "Insert a message about obsolete package at point." + (guix-info-insert-indent) + (guix-format-insert guix-package-info-obsolete-string + 'guix-package-info-obsolete)) + +(defun guix-package-info-insert-non-unique-text (full-name) + "Insert a message about non-unique package with FULL-NAME at point." + (insert "\n") + (guix-info-insert-indent) + (insert "Installed outputs are displayed for a non-unique ") + (guix-insert-button full-name 'guix-package-name) + (insert " package.")) + +(defun guix-package-info-insert-output (output entry) + "Insert OUTPUT at point. +Make some fancy text with buttons and additional stuff if the +current OUTPUT is installed (if there is such output in +`installed' parameter of a package ENTRY)." + (let* ((installed (guix-entry-value entry 'installed)) + (obsolete (guix-entry-value entry 'obsolete)) + (installed-entry (cl-find-if + (lambda (entry) + (string= (guix-entry-value entry 'output) + output)) + installed)) + (action-type (if installed-entry 'delete 'install))) + (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-output 2)))) + +(defun guix-package-info-insert-action-button (type entry output) + "Insert button to process an action on a package OUTPUT at point. +TYPE is one of the following symbols: `install', `delete', `upgrade'. +ENTRY is an alist with package info." + (let ((type-str (capitalize (symbol-name type))) + (full-name (guix-package-entry->name-specification entry output))) + (guix-info-insert-action-button + type-str + (lambda (btn) + (guix-process-package-actions + (guix-ui-current-profile) + `((,(button-get btn 'action-type) (,(button-get btn 'id) + ,(button-get btn 'output)))) + (current-buffer))) + (concat type-str " '" full-name "'") + 'action-type type + 'id (or (guix-entry-value entry 'package-id) + (guix-entry-id entry)) + 'output output))) + +(defun guix-package-info-show-source (entry-id package-id) + "Show file name of a package source in the current info buffer. +Find the file if needed (see `guix-package-info-auto-find-source'). +ENTRY-ID is an ID of the current entry (package or output). +PACKAGE-ID is an ID of the package which source to show." + (let* ((entries (guix-buffer-current-entries)) + (entry (guix-entry-by-id entry-id entries)) + (file (guix-package-source-path package-id))) + (or file + (error "Couldn't define file name of the package source")) + (let* ((new-entry (cons (cons 'source-file file) + entry)) + (new-entries (guix-replace-entry entry-id new-entry entries))) + (setf (guix-buffer-item-entries guix-buffer-item) + new-entries) + (guix-buffer-redisplay-goto-button) + (if (file-exists-p file) + (if guix-package-info-auto-find-source + (guix-find-file file) + (message "The source store path is displayed.")) + (if guix-package-info-auto-download-source + (guix-package-info-download-source package-id) + (message "The source does not exist in the store.")))))) + +(defun guix-package-info-download-source (package-id) + "Download a source of the package PACKAGE-ID." + (setq guix-package-info-download-buffer (current-buffer)) + (guix-package-source-build-derivation + package-id + "The source does not exist in the store. Download it?")) + +(defun guix-package-info-insert-source (source entry) + "Insert SOURCE from package ENTRY at point. +SOURCE is a list of URLs." + (if (null source) + (guix-format-insert nil) + (let* ((source-file (guix-entry-value entry 'source-file)) + (entry-id (guix-entry-id entry)) + (package-id (or (guix-entry-value entry 'package-id) + entry-id))) + (if (null source-file) + (guix-info-insert-action-button + "Show" + (lambda (btn) + (guix-package-info-show-source (button-get btn 'entry-id) + (button-get btn 'package-id))) + "Show the source store directory of the current package" + 'entry-id entry-id + 'package-id package-id) + (unless (file-exists-p source-file) + (guix-info-insert-action-button + "Download" + (lambda (btn) + (guix-package-info-download-source + (button-get btn 'package-id))) + "Download the source into the store" + 'package-id package-id)) + (guix-info-insert-value-indent source-file 'guix-file)) + (guix-info-insert-value-indent source 'guix-package-source)))) + +(defun guix-package-info-redisplay-after-download () + "Redisplay an 'info' buffer after downloading the package source. +This function is used to hide a \"Download\" button if needed." + (when (buffer-live-p guix-package-info-download-buffer) + (with-current-buffer guix-package-info-download-buffer + (guix-buffer-redisplay-goto-button)) + (setq guix-package-info-download-buffer nil))) + +(add-hook 'guix-after-source-download-hook + 'guix-package-info-redisplay-after-download) + + +;;; Package 'list' + +(guix-ui-list-define-interface package + :buffer-name "*Guix Package List*" + :format '((name guix-package-list-get-name 20 t) + (version nil 10 nil) + (outputs nil 13 t) + (installed guix-package-list-get-installed-outputs 13 t) + (synopsis guix-list-get-one-line 30 nil)) + :sort-key '(name) + :marks '((install . ?I) + (upgrade . ?U) + (delete . ?D))) + +(let ((map guix-package-list-mode-map)) + (define-key map (kbd "B") 'guix-package-list-latest-builds) + (define-key map (kbd "e") 'guix-package-list-edit) + (define-key map (kbd "x") 'guix-package-list-execute) + (define-key map (kbd "i") 'guix-package-list-mark-install) + (define-key map (kbd "d") 'guix-package-list-mark-delete) + (define-key map (kbd "U") 'guix-package-list-mark-upgrade) + (define-key map (kbd "^") 'guix-package-list-mark-upgrades)) + +(defface guix-package-list-installed + '((t :inherit guix-package-info-installed-outputs)) + "Face used if there are installed outputs for the current package." + :group 'guix-package-list-faces) + +(defface guix-package-list-obsolete + '((t :inherit guix-package-info-obsolete)) + "Face used if a package is obsolete." + :group 'guix-package-list-faces) + +(defcustom guix-package-list-generation-marking-enabled nil + "If non-nil, allow putting marks in a list with 'generation packages'. + +By default this is disabled, because it may be confusing. For +example, a package is installed in some generation, so a user can +mark it for deletion in the list of packages from this +generation, but the package may not be installed in the latest +generation, so actually it cannot be deleted. + +If you managed to understand the explanation above or if you +really know what you do or if you just don't care, you can set +this variable to t. It should not do much harm anyway (most +likely)." + :type 'boolean + :group 'guix-package-list) + +(defun guix-package-list-get-name (name entry) + "Return NAME of the package ENTRY. +Colorize it with `guix-package-list-installed' or +`guix-package-list-obsolete' if needed." + (guix-get-string name + (cond ((guix-entry-value entry 'obsolete) + 'guix-package-list-obsolete) + ((guix-entry-value entry 'installed) + 'guix-package-list-installed)))) + +(defun guix-package-list-get-installed-outputs (installed &optional _) + "Return string with outputs from INSTALLED entries." + (guix-get-string + (mapcar (lambda (entry) + (guix-entry-value entry 'output)) + installed))) + +(defun guix-package-list-marking-check () + "Signal an error if marking is disabled for the current buffer." + (when (and (not guix-package-list-generation-marking-enabled) + (or (derived-mode-p 'guix-package-list-mode) + (derived-mode-p 'guix-output-list-mode)) + (eq (guix-ui-current-search-type) 'generation)) + (error "Action marks are disabled for lists of 'generation packages'"))) + +(defun guix-package-list-mark-outputs (mark default + &optional prompt available) + "Mark the current package with MARK and move to the next line. +If PROMPT is non-nil, use it to ask a user for outputs from +AVAILABLE list, otherwise mark all DEFAULT outputs." + (let ((outputs (if prompt + (guix-completing-read-multiple + prompt available nil t) + default))) + (apply #'guix-list--mark mark t outputs))) + +(defun guix-package-list-mark-install (&optional arg) + "Mark the current package for installation and move to the next line. +With ARG, prompt for the outputs to install (several outputs may +be separated with \",\")." + (interactive "P") + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (all (guix-entry-value entry 'outputs)) + (installed (guix-package-installed-outputs entry)) + (available (cl-set-difference all installed :test #'string=))) + (or available + (user-error "This package is already installed")) + (guix-package-list-mark-outputs + 'install '("out") + (and arg "Output(s) to install: ") + available))) + +(defun guix-package-list-mark-delete (&optional arg) + "Mark the current package for deletion and move to the next line. +With ARG, prompt for the outputs to delete (several outputs may +be separated with \",\")." + (interactive "P") + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (installed (guix-package-installed-outputs entry))) + (or installed + (user-error "This package is not installed")) + (guix-package-list-mark-outputs + 'delete installed + (and arg "Output(s) to delete: ") + installed))) + +(defun guix-package-list-mark-upgrade (&optional arg) + "Mark the current package for upgrading and move to the next line. +With ARG, prompt for the outputs to upgrade (several outputs may +be separated with \",\")." + (interactive "P") + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (installed (guix-package-installed-outputs entry))) + (or installed + (user-error "This package is not installed")) + (when (or (guix-entry-value entry 'obsolete) + (y-or-n-p "This package is not obsolete. Try to upgrade it anyway? ")) + (guix-package-list-mark-outputs + 'upgrade installed + (and arg "Output(s) to upgrade: ") + installed)))) + +(defun guix-package-mark-upgrades (fun) + "Mark all obsolete packages for upgrading. +Use FUN to perform marking of the current line. FUN should +take an entry as argument." + (guix-package-list-marking-check) + (let ((obsolete (cl-remove-if-not + (lambda (entry) + (guix-entry-value entry 'obsolete)) + (guix-buffer-current-entries)))) + (guix-list-for-each-line + (lambda () + (let* ((id (guix-list-current-id)) + (entry (cl-find-if + (lambda (entry) + (equal id (guix-entry-id entry))) + obsolete))) + (when entry + (funcall fun entry))))))) + +(defun guix-package-list-mark-upgrades () + "Mark all obsolete packages for upgrading." + (interactive) + (guix-package-mark-upgrades + (lambda (entry) + (apply #'guix-list--mark + 'upgrade nil + (guix-package-installed-outputs entry))))) + +(defun guix-package-execute-actions (fun) + "Perform actions on the marked packages. +Use FUN to define actions suitable for `guix-process-package-actions'. +FUN should take action-type as argument." + (let ((actions (delq nil + (mapcar fun '(install delete upgrade))))) + (if actions + (guix-process-package-actions (guix-ui-current-profile) + actions (current-buffer)) + (user-error "No operations specified")))) + +(defun guix-package-list-execute () + "Perform actions on the marked packages." + (interactive) + (guix-package-execute-actions #'guix-package-list-make-action)) + +(defun guix-package-list-make-action (action-type) + "Return action specification for the packages marked with ACTION-TYPE. +Return nil, if there are no packages marked with ACTION-TYPE. +The specification is suitable for `guix-process-package-actions'." + (let ((specs (guix-list-get-marked-args action-type))) + (and specs (cons action-type specs)))) + +(defun guix-package-list-edit () + "Go to the location of the current package." + (interactive) + (guix-edit (guix-list-current-id))) + +(defun guix-package-list-latest-builds (number &rest args) + "Display latest NUMBER of Hydra builds of the current package. +Interactively, prompt for NUMBER. With prefix argument, prompt +for all ARGS." + (interactive + (let ((entry (guix-list-current-entry))) + (guix-hydra-build-latest-prompt-args + :job (guix-package-name-specification + (guix-entry-value entry 'name) + (guix-entry-value entry 'version))))) + (apply #'guix-hydra-latest-builds number args)) + + +;;; Output 'info' + +(guix-ui-info-define-interface output + :buffer-name "*Guix Package Info*" + :format '((name format (format guix-package-info-name)) + (version format guix-output-info-insert-version) + (output format guix-output-info-insert-output) + (synopsis simple (indent guix-package-info-synopsis)) + (source simple guix-package-info-insert-source) + (path simple (indent guix-file)) + (dependencies simple (indent guix-file)) + (location format (format guix-package-location)) + (home-url format (format guix-url)) + (license format (format guix-package-info-license)) + (inputs format (format guix-package-input)) + (native-inputs format (format guix-package-native-input)) + (propagated-inputs format + (format guix-package-propagated-input)) + (description simple (indent guix-package-info-description))) + :titles guix-package-info-titles + :required '(id package-id installed non-unique)) + +(defun guix-output-info-insert-version (version entry) + "Insert output VERSION and obsolete text if needed at point." + (guix-info-insert-value-format version + 'guix-package-info-version) + (and (guix-entry-value entry 'obsolete) + (guix-package-info-insert-obsolete-text))) + +(defun guix-output-info-insert-output (output entry) + "Insert OUTPUT and action buttons at point." + (let* ((installed (guix-entry-value entry 'installed)) + (obsolete (guix-entry-value entry 'obsolete)) + (action-type (if installed 'delete 'install))) + (guix-info-insert-value-format + output + (if installed + 'guix-package-info-installed-outputs + 'guix-package-info-uninstalled-outputs)) + (guix-info-insert-indent) + (guix-package-info-insert-action-button action-type entry output) + (when obsolete + (guix-info-insert-indent) + (guix-package-info-insert-action-button 'upgrade entry output)))) + + +;;; Output 'list' + +(guix-ui-list-define-interface output + :buffer-name "*Guix Package List*" + :describe-function 'guix-output-list-describe + :format '((name guix-package-list-get-name 20 t) + (version nil 10 nil) + (output nil 9 t) + (installed nil 12 t) + (synopsis guix-list-get-one-line 30 nil)) + :required '(id package-id) + :sort-key '(name) + :marks '((install . ?I) + (upgrade . ?U) + (delete . ?D))) + +(let ((map guix-output-list-mode-map)) + (define-key map (kbd "B") 'guix-package-list-latest-builds) + (define-key map (kbd "e") 'guix-output-list-edit) + (define-key map (kbd "x") 'guix-output-list-execute) + (define-key map (kbd "i") 'guix-output-list-mark-install) + (define-key map (kbd "d") 'guix-output-list-mark-delete) + (define-key map (kbd "U") 'guix-output-list-mark-upgrade) + (define-key map (kbd "^") 'guix-output-list-mark-upgrades)) + +(defun guix-output-list-mark-install () + "Mark the current output for installation and move to the next line." + (interactive) + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (installed (guix-entry-value entry 'installed))) + (if installed + (user-error "This output is already installed") + (guix-list--mark 'install t)))) + +(defun guix-output-list-mark-delete () + "Mark the current output for deletion and move to the next line." + (interactive) + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (installed (guix-entry-value entry 'installed))) + (if installed + (guix-list--mark 'delete t) + (user-error "This output is not installed")))) + +(defun guix-output-list-mark-upgrade () + "Mark the current output for upgrading and move to the next line." + (interactive) + (guix-package-list-marking-check) + (let* ((entry (guix-list-current-entry)) + (installed (guix-entry-value entry 'installed))) + (or installed + (user-error "This output is not installed")) + (when (or (guix-entry-value entry 'obsolete) + (y-or-n-p "This output is not obsolete. Try to upgrade it anyway? ")) + (guix-list--mark 'upgrade t)))) + +(defun guix-output-list-mark-upgrades () + "Mark all obsolete package outputs for upgrading." + (interactive) + (guix-package-mark-upgrades + (lambda (_) (guix-list--mark 'upgrade)))) + +(defun guix-output-list-execute () + "Perform actions on the marked outputs." + (interactive) + (guix-package-execute-actions #'guix-output-list-make-action)) + +(defun guix-output-list-make-action (action-type) + "Return action specification for the outputs marked with ACTION-TYPE. +Return nil, if there are no outputs marked with ACTION-TYPE. +The specification is suitable for `guix-process-output-actions'." + (let ((ids (guix-list-get-marked-id-list action-type))) + (and ids (cons action-type + (mapcar #'guix-package-id-and-output-by-output-id + ids))))) + +(defun guix-output-list-describe (ids) + "Describe outputs with IDS (list of output identifiers). +See `guix-package-info-type'." + (if (eq guix-package-info-type 'output) + (guix-buffer-get-display-entries + 'info 'output + (cl-list* (guix-ui-current-profile) 'id ids) + 'add) + (let ((pids (mapcar (lambda (oid) + (car (guix-package-id-and-output-by-output-id + oid))) + ids))) + (guix-buffer-get-display-entries + 'info 'package + (cl-list* (guix-ui-current-profile) + 'id (cl-remove-duplicates pids)) + 'add)))) + +(defun guix-output-list-edit () + "Go to the location of the current package." + (interactive) + (guix-edit (guix-entry-value (guix-list-current-entry) + 'package-id))) + + +;;; Interactive commands + +(defvar guix-package-search-params '(name synopsis description) + "Default list of package parameters for searching by regexp.") + +(defvar guix-package-search-history nil + "A history of minibuffer prompts.") + +;;;###autoload +(defun guix-search-by-name (name &optional profile) + "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\". + +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive + (list (read-string "Package name: " nil 'guix-package-search-history) + (guix-ui-read-profile))) + (guix-package-get-display profile 'name name)) + +;;;###autoload +(defun guix-search-by-regexp (regexp &optional params profile) + "Search for Guix packages by REGEXP. +PARAMS are package parameters that should be searched. +If PARAMS are not specified, use `guix-package-search-params'. + +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive + (list (read-regexp "Regexp: " nil 'guix-package-search-history) + nil (guix-ui-read-profile))) + (guix-package-get-display profile 'regexp regexp + (or params guix-package-search-params))) + +;;;###autoload +(defun guix-installed-packages (&optional profile) + "Display information about installed Guix packages. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive (list (guix-ui-read-profile))) + (guix-package-get-display profile 'installed)) + +;;;###autoload +(defun guix-obsolete-packages (&optional profile) + "Display information about obsolete Guix packages. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive (list (guix-ui-read-profile))) + (guix-package-get-display profile 'obsolete)) + +;;;###autoload +(defun guix-all-available-packages (&optional profile) + "Display information about all available Guix packages. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive (list (guix-ui-read-profile))) + (guix-package-get-display profile 'all-available)) + +;;;###autoload +(defun guix-newest-available-packages (&optional profile) + "Display information about the newest available Guix packages. +If PROFILE is nil, use `guix-current-profile'. +Interactively with prefix, prompt for PROFILE." + (interactive (list (guix-ui-read-profile))) + (guix-package-get-display profile 'newest-available)) + +(provide 'guix-ui-package) + +;;; guix-ui-package.el ends here diff --git a/emacs/guix-ui.el b/emacs/guix-ui.el new file mode 100644 index 0000000000..7fef7c355c --- /dev/null +++ b/emacs/guix-ui.el @@ -0,0 +1,333 @@ +;;; guix-ui.el --- Common code for Guix package management interface -*- lexical-binding: t -*- + +;; Copyright © 2014, 2015 Alex Kost <alezost@gmail.com> + +;; This file is part of GNU Guix. + +;; GNU Guix is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Guix is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides some general code for 'list'/'info' interfaces for +;; packages and generations. + +;;; Code: + +(require 'cl-lib) +(require 'guix-backend) +(require 'guix-buffer) +(require 'guix-guile) +(require 'guix-utils) +(require 'guix-messages) + +(guix-define-groups ui + :group-doc "\ +Settings for 'ui' (Guix package management) buffers. +This group includes settings for displaying packages, outputs and +generations in 'list' and 'info' buffers.") + +(defvar guix-ui-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M") 'guix-apply-manifest) + (define-key map (kbd "C-c C-z") 'guix-switch-to-repl) + map) + "Parent keymap for Guix package/generation buffers.") + +(guix-buffer-define-current-args-accessors + "guix-ui-current" "profile" "search-type" "search-values") + +(defun guix-ui-read-profile () + "Return `guix-current-profile' or prompt for it. +This function is intended for using in `interactive' forms." + (if current-prefix-arg + (guix-profile-prompt) + guix-current-profile)) + +(defun guix-ui-get-entries (profile entry-type search-type search-values + &optional params) + "Receive ENTRY-TYPE entries for PROFILE. +Call an appropriate scheme procedure and return a list of entries. + +ENTRY-TYPE should be one of the following symbols: `package', +`output' or `generation'. + +SEARCH-TYPE may be one of the following symbols: + +- If ENTRY-TYPE is `package' or `output': `id', `name', `regexp', + `all-available', `newest-available', `installed', `obsolete', + `generation'. + +- If ENTRY-TYPE is `generation': `id', `last', `all', `time'. + +PARAMS is a list of parameters for receiving. If nil, get data +with all available parameters." + (guix-eval-read + (guix-make-guile-expression + 'entries + profile params entry-type search-type search-values))) + +(defun guix-ui-list-describe (ids) + "Describe 'ui' entries with IDS (list of identifiers)." + (guix-buffer-get-display-entries + 'info (guix-buffer-current-entry-type) + (cl-list* (guix-ui-current-profile) 'id ids) + 'add)) + + +;;; Buffers and auto updating + +(defcustom guix-ui-update-after-operation 'current + "Define what kind of data to update after executing an operation. + +After successful executing an operation in the Guix REPL (for +example after installing a package), the data in Guix buffers +will or will not be automatically updated depending on a value of +this variable. + +If nil, update nothing (do not revert any buffer). +If `current', update the buffer from which an operation was performed. +If `all', update all Guix buffers (not recommended)." + :type '(choice (const :tag "Do nothing" nil) + (const :tag "Update operation buffer" current) + (const :tag "Update all Guix buffers" all)) + :group 'guix-ui) + +(defcustom guix-ui-buffer-name-function + #'guix-ui-buffer-name-default + "Function used to define a name of a Guix buffer. +The function is called with 2 arguments: BASE-NAME and PROFILE." + :type '(choice (function-item guix-ui-buffer-name-default) + (function-item guix-ui-buffer-name-simple) + (function :tag "Other function")) + :group 'guix-ui) + +(defun guix-ui-buffer-name-simple (base-name &rest _) + "Return BASE-NAME." + base-name) + +;; TODO separate '*...*' logic from the real profile appending. Also add +;; another function to return '*Guix ...: /full/path/to/profile*' name. +(defun guix-ui-buffer-name-default (base-name profile) + "Return buffer name by appending BASE-NAME and PROFILE's base file name." + (let ((profile-name (file-name-base (directory-file-name profile))) + (re (rx string-start + (group (? "*")) + (group (*? any)) + (group (? "*")) + string-end))) + (or (string-match re base-name) + (error "Unexpected error in defining guix buffer name")) + (let ((first* (match-string 1 base-name)) + (name-body (match-string 2 base-name)) + (last* (match-string 3 base-name))) + ;; Handle the case when buffer name is wrapped by '*'. + (if (and (string= "*" first*) + (string= "*" last*)) + (concat "*" name-body ": " profile-name "*") + (concat base-name ": " profile-name))))) + +(defun guix-ui-buffer-name (base-name profile) + "Return Guix buffer name based on BASE-NAME and profile. +See `guix-ui-buffer-name-function' for details." + (funcall guix-ui-buffer-name-function + base-name profile)) + +(defun guix-ui-buffer? (&optional buffer modes) + "Return non-nil if BUFFER mode is derived from any of the MODES. +If BUFFER is nil, check current buffer. +If MODES is nil, use `guix-list-mode' and `guix-info-mode'." + (with-current-buffer (or buffer (current-buffer)) + (apply #'derived-mode-p + (or modes '(guix-list-mode guix-info-mode))))) + +(defun guix-ui-buffers (&optional modes) + "Return a list of all buffers with major modes derived from MODES. +If MODES is nil, return list of all Guix 'list' and 'info' buffers." + (cl-remove-if-not (lambda (buf) + (guix-ui-buffer? buf modes)) + (buffer-list))) + +(defun guix-ui-update-buffer (buffer) + "Update data in a 'list' or 'info' BUFFER." + (with-current-buffer buffer + (guix-buffer-revert nil t))) + +(defun guix-ui-update-buffers-after-operation () + "Update buffers after Guix operation if needed. +See `guix-ui-update-after-operation' for details." + (let ((to-update + (and guix-operation-buffer + (cl-case guix-ui-update-after-operation + (current (and (buffer-live-p guix-operation-buffer) + (guix-ui-buffer? guix-operation-buffer) + (list guix-operation-buffer))) + (all (guix-ui-buffers)))))) + (setq guix-operation-buffer nil) + (mapc #'guix-ui-update-buffer to-update))) + +(add-hook 'guix-after-repl-operation-hook + 'guix-ui-update-buffers-after-operation) + + +;;; Interface definers + +(defmacro guix-ui-define-entry-type (entry-type &rest args) + "Define general code for ENTRY-TYPE. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +The rest keyword arguments are passed to +`guix-define-entry-type' macro." + (declare (indent 1)) + `(guix-define-entry-type ,entry-type + :parent-group guix-ui + :parent-faces-group guix-ui-faces + ,@args)) + +(defmacro guix-ui-define-interface (buffer-type entry-type &rest args) + "Define BUFFER-TYPE interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... +In the following description TYPE means ENTRY-TYPE-BUFFER-TYPE. + +Required keywords: + + - `:buffer-name' - base part of a buffer name. It is used in a + generated `guix-TYPE-buffer-name' function; see + `guix-ui-buffer-name' for details. + +Optional keywords: + + - `:required' - default value of the generated + `guix-TYPE-required-params' variable. + +The rest keyword arguments are passed to +`guix-BUFFER-TYPE-define-interface' macro. + +Along with the mentioned definitions, this macro also defines: + + - `guix-TYPE-mode-map' - keymap based on `guix-ui-map' and + `guix-BUFFER-TYPE-mode-map'. + + - `guix-TYPE-get-entries' - a wrapper around `guix-ui-get-entries'. + + - `guix-TYPE-message' - a wrapper around `guix-result-message'." + (declare (indent 2)) + (let* ((entry-type-str (symbol-name entry-type)) + (buffer-type-str (symbol-name buffer-type)) + (prefix (concat "guix-" entry-type-str "-" + buffer-type-str)) + (mode-str (concat prefix "-mode")) + (mode-map (intern (concat mode-str "-map"))) + (parent-map (intern (format "guix-%s-mode-map" + buffer-type-str))) + (required-var (intern (concat prefix "-required-params"))) + (buffer-name-fun (intern (concat prefix "-buffer-name"))) + (get-fun (intern (concat prefix "-get-entries"))) + (message-fun (intern (concat prefix "-message"))) + (displayed-fun (intern (format "guix-%s-displayed-params" + buffer-type-str))) + (definer (intern (format "guix-%s-define-interface" + buffer-type-str)))) + (guix-keyword-args-let args + ((buffer-name-val :buffer-name) + (required-val :required ''(id))) + `(progn + (defvar ,mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent + map (make-composed-keymap ,parent-map guix-ui-map)) + map) + ,(format "Keymap for `%s' buffers." mode-str)) + + (defvar ,required-var ,required-val + ,(format "\ +List of the required '%s' parameters. +These parameters are received by `%S' +along with the displayed parameters. + +Do not remove `id' from this list as it is required for +identifying an entry." + entry-type-str get-fun)) + + (defun ,buffer-name-fun (profile &rest _) + ,(format "\ +Return a name of '%s' buffer for displaying '%s' entries. +See `guix-ui-buffer-name' for details." + buffer-type-str entry-type-str) + (guix-ui-buffer-name ,buffer-name-val profile)) + + (defun ,get-fun (profile search-type &rest search-values) + ,(format "\ +Receive '%s' entries for displaying them in '%s' buffer. +See `guix-ui-get-entries' for details." + entry-type-str buffer-type-str) + (guix-ui-get-entries + profile ',entry-type search-type search-values + (cl-union ,required-var + (,displayed-fun ',entry-type)))) + + (defun ,message-fun (entries profile search-type + &rest search-values) + ,(format "\ +Display a message after showing '%s' entries." + entry-type-str) + (guix-result-message + profile entries ',entry-type search-type search-values)) + + (,definer ,entry-type + :get-entries-function ',get-fun + :message-function ',message-fun + :buffer-name ',buffer-name-fun + ,@%foreign-args))))) + +(defmacro guix-ui-info-define-interface (entry-type &rest args) + "Define 'info' interface for displaying ENTRY-TYPE entries. +See `guix-ui-define-interface'." + (declare (indent 1)) + `(guix-ui-define-interface info ,entry-type + ,@args)) + +(defmacro guix-ui-list-define-interface (entry-type &rest args) + "Define 'list' interface for displaying ENTRY-TYPE entries. +Remaining arguments (ARGS) should have a form [KEYWORD VALUE] ... + +Optional keywords: + + - `:describe-function' - default value of the generated + `guix-ENTRY-TYPE-list-describe-function' variable (if not + specified, use `guix-ui-list-describe'). + +The rest keyword arguments are passed to +`guix-ui-define-interface' macro." + (declare (indent 1)) + (guix-keyword-args-let args + ((describe-val :describe-function)) + `(guix-ui-define-interface list ,entry-type + :describe-function ,(or describe-val ''guix-ui-list-describe) + ,@args))) + + +(defvar guix-ui-font-lock-keywords + (eval-when-compile + `((,(rx "(" (group (or "guix-ui-define-entry-type" + "guix-ui-define-interface" + "guix-ui-info-define-interface" + "guix-ui-list-define-interface")) + symbol-end) + . 1)))) + +(font-lock-add-keywords 'emacs-lisp-mode guix-ui-font-lock-keywords) + +(provide 'guix-ui) + +;;; guix-ui.el ends here diff --git a/emacs/guix-utils.el b/emacs/guix-utils.el index 5f3f3ecc10..8c1a5b42de 100644 --- a/emacs/guix-utils.el +++ b/emacs/guix-utils.el @@ -64,6 +64,17 @@ Use `guix-time-format'." "Return one-line string from a multi-line STR." (replace-regexp-in-string "\n" " " str)) +(defmacro guix-with-indent (indent &rest body) + "Evaluate BODY and indent inserted text by INDENT number of spaces." + (declare (indent 1) (debug t)) + (let ((region-beg-var (make-symbol "region-beg")) + (indent-var (make-symbol "indent"))) + `(let ((,region-beg-var (point)) + (,indent-var ,indent)) + ,@body + (unless (zerop ,indent-var) + (indent-rigidly ,region-beg-var (point) ,indent-var))))) + (defun guix-format-insert (val &optional face format) "Convert VAL into a string and insert it at point. If FACE is non-nil, propertize VAL with FACE. @@ -93,6 +104,28 @@ See `insert-text-button' for the meaning of PROPERTIES." :type (or type 'button) properties))) +(defun guix-buttonize (value button-type separator &rest properties) + "Make BUTTON-TYPE button(s) from VALUE. +Return a string with button(s). + +VALUE should be a string or a list of strings. If it is a list +of strings, buttons are separated with SEPARATOR string. + +PROPERTIES are passed to `guix-insert-button'." + (with-temp-buffer + (let ((labels (if (listp value) value (list value)))) + (guix-mapinsert (lambda (label) + (apply #'guix-insert-button + label button-type properties)) + labels + separator)) + (buffer-substring (point-min) (point-max)))) + +(defun guix-button-type? (symbol) + "Return non-nil, if SYMBOL is a button type." + (and symbol + (get symbol 'button-category-symbol))) + (defun guix-split-insert (val &optional face col separator) "Convert VAL into a string, split it and insert at point. @@ -111,14 +144,11 @@ Separate inserted lines with 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))) +If COL is non-nil, fill STR to this column." + (let ((str (if col + (guix-get-filled-string str col) + str))) + (split-string str "\n *" t))) (defun guix-get-filled-string (str col) "Return string by filling STR to column COL." @@ -144,6 +174,15 @@ add both to the end and to the beginning." (t (concat separator str separator))))) +(defun guix-hexify (value) + "Convert VALUE to string and hexify it." + (url-hexify-string (guix-get-string value))) + +(defun guix-number->bool (number) + "Convert NUMBER to boolean value. +Return nil, if NUMBER is 0; return t otherwise." + (not (zerop number))) + (defun guix-shell-quote-argument (argument) "Quote shell command ARGUMENT. This function is similar to `shell-quote-argument', but less strict." @@ -154,6 +193,15 @@ This function is similar to `shell-quote-argument', but less strict." (replace-regexp-in-string (rx (not (any alnum "-=,./\n"))) "\\\\\\&" argument)))) +(defun guix-symbol-title (symbol) + "Return SYMBOL's name, a string. +This is like `symbol-name', but fancier." + (if (eq symbol 'id) + "ID" + (let ((str (replace-regexp-in-string "-" " " (symbol-name symbol)))) + (concat (capitalize (substring str 0 1)) + (substring str 1))))) + (defun guix-command-symbol (&optional args) "Return symbol by concatenating 'guix' and ARGS (strings)." (intern (guix-concat-strings (cons "guix" args) "-"))) @@ -175,6 +223,15 @@ If NO-MESSAGE? is non-nil, do not display a message about it." See also `guix-copy-as-kill'." (guix-copy-as-kill (guix-command-string args) no-message?)) +(defun guix-completing-read (prompt table &optional predicate + require-match initial-input + hist def inherit-input-method) + "Same as `completing-read' but return nil instead of an empty string." + (let ((res (completing-read prompt table predicate + require-match initial-input + hist def inherit-input-method))) + (unless (string= "" res) res))) + (defun guix-completing-read-multiple (prompt table &optional predicate require-match initial-input hist def inherit-input-method) @@ -193,6 +250,14 @@ Return time value." (require 'org) (org-read-date nil t nil prompt)) +(defun guix-read-file-name (prompt &optional dir default-filename + mustmatch initial predicate) + "Read file name. +This function is similar to `read-file-name' except it also +expands the file name." + (expand-file-name (read-file-name prompt dir default-filename + mustmatch initial predicate))) + (defcustom guix-find-file-function #'find-file "Function used to find a file. The function is called by `guix-find-file' with a file name as a @@ -226,6 +291,15 @@ single argument." (while (re-search-forward ,regexp nil t) ,@body))) +(defmacro guix-while-null (&rest body) + "Evaluate BODY until its result becomes non-nil." + (declare (indent 0) (debug t)) + (let ((result-var (make-symbol "result"))) + `(let (,result-var) + (while (null ,result-var) + (setq ,result-var ,@body)) + ,result-var))) + (defun guix-modify (object modifiers) "Apply MODIFIERS to OBJECT. OBJECT is passed as an argument to the first function from @@ -237,8 +311,57 @@ modifier call." (guix-modify (funcall (car modifiers) object) (cdr modifiers)))) +(defmacro guix-keyword-args-let (args varlist &rest body) + "Parse ARGS, bind variables from VARLIST and eval BODY. + +Find keyword values in ARGS, bind them to variables according to +VARLIST, then evaluate BODY. + +ARGS is a keyword/value property list. + +Each element of VARLIST has a form: + + (SYMBOL KEYWORD [DEFAULT-VALUE]) + +SYMBOL is a varible name. KEYWORD is a symbol that will be +searched in ARGS for an according value. If the value of KEYWORD +does not exist, bind SYMBOL to DEFAULT-VALUE or nil. + +The rest arguments (that present in ARGS but not in VARLIST) will +be bound to `%foreign-args' variable. + +Example: + + (guix-keyword-args-let '(:two 8 :great ! :guix is) + ((one :one 1) + (two :two 2) + (foo :smth)) + (list one two foo %foreign-args)) + + => (1 8 nil (:guix is :great !))" + (declare (indent 2)) + (let ((args-var (make-symbol "args"))) + `(let (,@(mapcar (lambda (spec) + (pcase-let ((`(,name ,_ ,val) spec)) + (list name val))) + varlist) + (,args-var ,args) + %foreign-args) + (while ,args-var + (pcase ,args-var + (`(,key ,val . ,rest-args) + (cl-case key + ,@(mapcar (lambda (spec) + (pcase-let ((`(,name ,key ,_) spec)) + `(,key (setq ,name val)))) + varlist) + (t (setq %foreign-args + (cl-list* key val %foreign-args)))) + (setq ,args-var rest-args)))) + ,@body))) + -;;; Alist accessors +;;; Alist procedures (defmacro guix-define-alist-accessor (name assoc-fun) "Define NAME function to access alist values using ASSOC-FUN." @@ -256,6 +379,48 @@ accessed with KEYS." (guix-define-alist-accessor guix-assq-value assq) (guix-define-alist-accessor guix-assoc-value assoc) +(defun guix-alist-put (value alist &rest keys) + "Put (add or replace if exists) VALUE to ALIST using KEYS. +Return the new alist. + +ALIST is alist of alists of alists ... which can be consecutively +accessed with KEYS. + +Example: + + (guix-alist-put + 'foo + '((one (a . 1) (b . 2)) + (two (m . 7) (n . 8))) + 'one 'b) + + => ((one (a . 1) (b . foo)) + (two (m . 7) (n . 8)))" + (or keys (error "Keys should be specified")) + (guix-alist-put-1 value alist keys)) + +(defun guix-alist-put-1 (value alist keys) + "Subroutine of `guix-alist-put'." + (cond + ((null keys) + value) + ((null alist) + (list (cons (car keys) + (guix-alist-put-1 value nil (cdr keys))))) + ((eq (car keys) (caar alist)) + (cons (cons (car keys) + (guix-alist-put-1 value (cdar alist) (cdr keys))) + (cdr alist))) + (t + (cons (car alist) + (guix-alist-put-1 value (cdr alist) keys))))) + +(defun guix-alist-put! (value variable &rest keys) + "Modify alist VARIABLE (symbol) by putting VALUE using KEYS. +See `guix-alist-put' for details." + (set variable + (apply #'guix-alist-put value (symbol-value variable) keys))) + ;;; Diff @@ -267,6 +432,77 @@ accessed with KEYS." (diff old new (or switches guix-diff-switches) no-async)) +;;; Completing readers definers + +(defmacro guix-define-reader (name read-fun completions prompt) + "Define NAME function to read from minibuffer. +READ-FUN may be `completing-read', `completing-read-multiple' or +another function with the same arguments." + `(defun ,name (&optional prompt initial-contents) + (,read-fun ,(if prompt + `(or prompt ,prompt) + 'prompt) + ,completions nil nil initial-contents))) + +(defmacro guix-define-readers (&rest args) + "Define reader functions. + +ARGS should have a form [KEYWORD VALUE] ... The following +keywords are available: + + - `completions-var' - variable used to get completions. + + - `completions-getter' - function used to get completions. + + - `single-reader', `single-prompt' - name of a function to read + a single value, and a prompt for it. + + - `multiple-reader', `multiple-prompt' - name of a function to + read multiple values, and a prompt for it. + + - `multiple-separator' - if specified, another + `<multiple-reader-name>-string' function returning a string + of multiple values separated the specified separator will be + defined." + (guix-keyword-args-let args + ((completions-var :completions-var) + (completions-getter :completions-getter) + (single-reader :single-reader) + (single-prompt :single-prompt) + (multiple-reader :multiple-reader) + (multiple-prompt :multiple-prompt) + (multiple-separator :multiple-separator)) + (let ((completions + (cond ((and completions-var completions-getter) + `(or ,completions-var + (setq ,completions-var + (funcall ',completions-getter)))) + (completions-var + completions-var) + (completions-getter + `(funcall ',completions-getter))))) + `(progn + ,(when (and completions-var + (not (boundp completions-var))) + `(defvar ,completions-var nil)) + + ,(when single-reader + `(guix-define-reader ,single-reader guix-completing-read + ,completions ,single-prompt)) + + ,(when multiple-reader + `(guix-define-reader ,multiple-reader completing-read-multiple + ,completions ,multiple-prompt)) + + ,(when (and multiple-reader multiple-separator) + (let ((name (intern (concat (symbol-name multiple-reader) + "-string")))) + `(defun ,name (&optional prompt initial-contents) + (guix-concat-strings + (,multiple-reader prompt initial-contents) + ,multiple-separator)))))))) + + ;;; Memoizing (defun guix-memoize (function) @@ -303,9 +539,18 @@ See `defun' for the meaning of arguments." ,(or docstring (format "Memoized version of `%S'." definition)))) -(defvar guix-memoized-font-lock-keywords + +(defvar guix-utils-font-lock-keywords (eval-when-compile - `((,(rx "(" + `((,(rx "(" (group (or "guix-define-reader" + "guix-define-readers" + "guix-keyword-args-let" + "guix-while-null" + "guix-while-search" + "guix-with-indent")) + symbol-end) + . 1) + (,(rx "(" (group "guix-memoized-" (or "defun" "defalias")) symbol-end (zero-or-more blank) @@ -314,7 +559,7 @@ See `defun' for the meaning of arguments." (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))))) -(font-lock-add-keywords 'emacs-lisp-mode guix-memoized-font-lock-keywords) +(font-lock-add-keywords 'emacs-lisp-mode guix-utils-font-lock-keywords) (provide 'guix-utils) diff --git a/emacs/guix.el b/emacs/guix.el deleted file mode 100644 index ac6efbb475..0000000000 --- a/emacs/guix.el +++ /dev/null @@ -1,213 +0,0 @@ -;;; guix.el --- Interface for GNU Guix package manager - -;; Copyright © 2014, 2015 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-base) -(require 'guix-list) -(require 'guix-info) -(require 'guix-utils) -(require 'guix-read) - -(defgroup guix nil - "Interface for Guix package manager." - :prefix "guix-" - :group 'external) - -(defgroup guix-faces nil - "Guix faces." - :group 'guix - :group 'faces) - -(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) - -(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 (profile search-type &rest search-vals) - "Search for packages and show results. - -If PROFILE is nil, use `guix-current-profile'. - -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." - (or profile (setq profile guix-current-profile)) - (let ((packages (guix-get-entries profile guix-package-list-type - search-type search-vals - (guix-get-params-for-receiving - 'list guix-package-list-type)))) - (if (or guix-list-single-package - (cdr packages)) - (guix-set-buffer profile packages 'list guix-package-list-type - search-type search-vals) - (let ((packages (guix-get-entries profile guix-package-info-type - search-type search-vals - (guix-get-params-for-receiving - 'info guix-package-info-type)))) - (guix-set-buffer profile packages 'info guix-package-info-type - search-type search-vals))))) - -(defun guix-get-show-generations (profile search-type &rest search-vals) - "Search for generations and show results. - -If PROFILE is nil, use `guix-current-profile'. - -See `guix-get-entries' for the meaning of SEARCH-TYPE and -SEARCH-VALS." - (apply #'guix-get-show-entries - (or profile guix-current-profile) - 'list 'generation search-type search-vals)) - -;;;###autoload -(defun guix-search-by-name (name &optional profile) - "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\". - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-string "Package name: " nil 'guix-search-history) - (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'name name)) - -;;;###autoload -(defun guix-search-by-regexp (regexp &optional params profile) - "Search for Guix packages by REGEXP. -PARAMS are package parameters that should be searched. -If PARAMS are not specified, use `guix-search-params'. - -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-regexp "Regexp: " nil 'guix-search-history) - nil - (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'regexp regexp - (or params guix-search-params))) - -;;;###autoload -(defun guix-installed-packages (&optional profile) - "Display information about installed Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'installed)) - -;;;###autoload -(defun guix-obsolete-packages (&optional profile) - "Display information about obsolete Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'obsolete)) - -;;;###autoload -(defun guix-all-available-packages (&optional profile) - "Display information about all available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'all-available)) - -;;;###autoload -(defun guix-newest-available-packages (&optional profile) - "Display information about the newest available Guix packages. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-packages profile 'newest-available)) - -;;;###autoload -(defun guix-generations (&optional profile) - "Display information about all generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-generations profile 'all)) - -;;;###autoload -(defun guix-last-generations (number &optional profile) - "Display information about last NUMBER generations. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (read-number "The number of last generations: ") - (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-generations profile 'last number)) - -;;;###autoload -(defun guix-generations-by-time (from to &optional profile) - "Display information about generations created between FROM and TO. -FROM and TO should be time values. -If PROFILE is nil, use `guix-current-profile'. -Interactively with prefix, prompt for PROFILE." - (interactive - (list (guix-read-date "Find generations (from): ") - (guix-read-date "Find generations (to): ") - (and current-prefix-arg - (guix-profile-prompt)))) - (guix-get-show-generations profile 'time - (float-time from) - (float-time to))) - -;;;###autoload -(defun guix-edit (id-or-name) - "Edit (go to location of) package with ID-OR-NAME." - (interactive (list (guix-read-package-name))) - (let ((loc (guix-package-location id-or-name))) - (if loc - (guix-find-location loc) - (message "Couldn't find package location.")))) - -(provide 'guix) - -;;; guix.el ends here |