X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/457f60fa068c7becf60841daa2b6fc5121aedead..78ab0746a523cc63eca0fd2fe55ac6c5b1ec5d5e:/emacs/guix-base.el diff --git a/emacs/guix-base.el b/emacs/guix-base.el index 563df496cd..5129c87a5d 100644 --- a/emacs/guix-base.el +++ b/emacs/guix-base.el @@ -1,4 +1,4 @@ -;;; guix-base.el --- Common definitions +;;; guix-base.el --- Common definitions -*- lexical-binding: t -*- ;; Copyright © 2014 Alex Kost @@ -28,42 +28,11 @@ ;;; Code: (require 'cl-lib) +(require 'guix-profiles) (require 'guix-backend) (require 'guix-utils) - - -;;; Profiles - -(defvar guix-user-profile - (expand-file-name "~/.guix-profile") - "User profile.") - -(defvar guix-default-profile - (concat (or (getenv "NIX_STATE_DIR") "/var/guix") - "/profiles/per-user/" - (getenv "USER") - "/guix-profile") - "Default Guix profile.") - -(defvar guix-current-profile guix-default-profile - "Current profile.") - -(defun guix-set-current-profile (path) - "Set `guix-current-profile' to PATH. -Interactively, prompt for PATH. With prefix, use -`guix-default-profile'." - (interactive - (list (if current-prefix-arg - guix-default-profile - (read-file-name "Set profile: " - (file-name-directory guix-current-profile))))) - (let ((path (directory-file-name (expand-file-name path)))) - (setq guix-current-profile - (if (string= path guix-user-profile) - guix-default-profile - path)) - (message "Current profile has been set to '%s'." - guix-current-profile))) +(require 'guix-history) +(require 'guix-messages) ;;; Parameters of the entries @@ -73,6 +42,7 @@ Interactively, prompt for PATH. With prefix, use (id . "ID") (name . "Name") (version . "Version") + (source . "Source") (license . "License") (synopsis . "Synopsis") (description . "Description") @@ -87,10 +57,28 @@ Interactively, prompt for PATH. With prefix, use (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. @@ -118,6 +106,17 @@ Each element of the list has a form: (guix-get-key-val entry 'version) output)) +(defun guix-entry-to-specification (entry) + "Return name specification by the package or output ENTRY." + (guix-get-name-spec (guix-get-key-val entry 'name) + (guix-get-key-val entry 'version) + (guix-get-key-val 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) @@ -130,6 +129,14 @@ Each element of the list has a form: (equal id (guix-get-key-val 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 @@ -166,8 +173,124 @@ If PATH is relative, it is considered to be relative to (recenter 1)))) +;;; 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-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 @@ -179,6 +302,14 @@ 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) @@ -187,48 +318,44 @@ VAL is a value of this parameter.") "Values of the current search.") (put 'guix-search-vals 'permanent-local t) -(defsubst guix-set-vars (entries search-type search-vals) - (setq guix-entries entries - guix-search-type search-type - guix-search-vals search-vals)) +(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 stuff for BUF-TYPE buffers for displaying entries. - -ENTRY-TYPE is a type of displayed entries (see -`guix-get-entries'). + "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, several user -variables and the following functions: - - - `guix-TYPE-get-params-for-receiving' - - `guix-TYPE-revert' - - `guix-TYPE-redisplay' - - `guix-TYPE-make-history-item' - - `guix-TYPE-set' - - `guix-TYPE-show' - - `guix-TYPE-get-show' +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-BUF-TYPE-insert-entries' - function for inserting - entries in the current buffer; it is called with 2 arguments: - entries of the form of `guix-entries' and ENTRY-TYPE. - - - `guix-BUF-TYPE-get-displayed-params' - function returning a - list of parameters displayed in the current buffer; it is - called with ENTRY-TYPE as argument. - - `guix-TYPE-mode-initialize' (optional) - function for additional mode settings; it is called without arguments. Remaining argument (ARGS) should have a form [KEYWORD VALUE] ... The following keywords are available: + - `:buffer-name' - default value for the defined + `guix-TYPE-buffer-name' variable. + - `:required' - default value for the defined `guix-TYPE-required-params' variable. @@ -252,15 +379,9 @@ following keywords are available: (mode-init-fun (intern (concat prefix "-mode-initialize"))) (buf-name-var (intern (concat prefix "-buffer-name"))) (revert-var (intern (concat prefix "-revert-no-confirm"))) - (revert-fun (intern (concat prefix "-revert"))) - (redisplay-fun (intern (concat prefix "-redisplay"))) (history-var (intern (concat prefix "-history-size"))) - (history-fun (intern (concat prefix "-make-history-item"))) (params-var (intern (concat prefix "-required-params"))) - (params-fun (intern (concat prefix "-get-params-for-receiving"))) - (set-fun (intern (concat prefix "-set"))) - (show-fun (intern (concat prefix "-show"))) - (get-show-fun (intern (concat prefix "-get-show"))) + (buf-name-val (format "*Guix %s %s*" Entry-type-str Buf-type-str)) (revert-val nil) (history-val 20) (params-val '(id))) @@ -271,6 +392,7 @@ following keywords are available: (`: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 @@ -279,8 +401,7 @@ following keywords are available: :prefix ,(concat prefix "-") :group ',(intern (concat "guix-" buf-type-str))) - (defcustom ,buf-name-var ,(format "*Guix %s %s*" - Entry-type-str Buf-type-str) + (defcustom ,buf-name-var ,buf-name-val ,(concat "Default name of the " buf-str " for displaying " entry-str ".") :type 'string :group ',group) @@ -309,7 +430,7 @@ following keywords are available: (define-derived-mode ,mode ,parent-mode ,(concat "Guix-" Buf-type-str) ,(concat "Major mode for displaying information about " entry-str ".\n\n" "\\{" mode-map-str "}") - (setq-local revert-buffer-function ',revert-fun) + (setq-local revert-buffer-function 'guix-revert-buffer) (setq-local guix-history-size ,history-var) (and (fboundp ',mode-init-fun) (,mode-init-fun))) @@ -317,185 +438,325 @@ following keywords are available: (define-key map (kbd "l") 'guix-history-back) (define-key map (kbd "r") 'guix-history-forward) (define-key map (kbd "g") 'revert-buffer) - (define-key map (kbd "R") ',redisplay-fun) - (define-key map (kbd "C-c C-z") 'guix-switch-to-repl)) - - (defun ,params-fun () - ,(concat "Return " entry-type-str " parameters that should be received.") - (unless (equal ,params-var 'all) - (cl-union ,params-var - (,(intern (concat "guix-" buf-type-str "-get-displayed-params")) - ',entry-type)))) - - (defun ,revert-fun (_ignore-auto noconfirm) - "Update information in the current buffer. -The function is suitable for `revert-buffer-function'. -See `revert-buffer' for the meaning of NOCONFIRM." - (when (or ,revert-var - noconfirm - (y-or-n-p "Update current information? ")) - (let ((entries (guix-get-entries ',entry-type guix-search-type - guix-search-vals (,params-fun)))) - (,set-fun entries guix-search-type guix-search-vals t)))) - - (defun ,redisplay-fun () - "Redisplay current information. -This function will not update the information, use -\"\\[revert-buffer]\" if you want the full update." - (interactive) - (,show-fun guix-entries) - (guix-result-message guix-entries ',entry-type - guix-search-type guix-search-vals)) - - (defun ,history-fun () - "Make and return a history item for the current buffer." - (list (lambda (entries search-type search-vals) - (,show-fun entries) - (guix-set-vars entries search-type search-vals) - (guix-result-message entries ',entry-type - search-type search-vals)) - guix-entries guix-search-type guix-search-vals)) - - (defun ,set-fun (entries search-type search-vals &optional history-replace) - ,(concat "Set up the " buf-str " for displaying " entry-str ".\n\n" - "Display ENTRIES, set variables and make history item.\n\n" - "ENTRIES should have a form of `guix-entries'.\n\n" - "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" - "SEARCH-VALS.\n\n" - "If HISTORY-REPLACE is non-nil, replace current history item,\n" - "otherwise add the new one.") - (when entries - (let ((buf (if (eq major-mode ',mode) - (current-buffer) - (get-buffer-create ,buf-name-var)))) - (with-current-buffer buf - (,show-fun entries) - (guix-set-vars entries search-type search-vals) - (funcall (if history-replace - #'guix-history-replace - #'guix-history-add) - (,history-fun))) - (pop-to-buffer buf - '((display-buffer-reuse-window - display-buffer-same-window))))) - (guix-result-message entries ',entry-type - search-type search-vals)) - - (defun ,show-fun (entries) - ,(concat "Display " entry-type-str " ENTRIES in the current " buf-str ".") - (let ((inhibit-read-only t)) - (erase-buffer) - (,mode) - (,(intern (concat "guix-" buf-type-str "-insert-entries")) - entries ',entry-type) - (goto-char (point-min)))) - - (defun ,get-show-fun (search-type &rest search-vals) - ,(concat "Search for " entry-str " and show results in the " buf-str ".\n" - "See `guix-get-entries' for the meaning of SEARCH-TYPE and\n" - "SEARCH-VALS.") - (let ((entries (guix-get-entries ',entry-type search-type - search-vals (,params-fun)))) - (,set-fun entries search-type search-vals)))))) + (define-key map (kbd "R") 'guix-redisplay-buffer) + (define-key map (kbd "C-c C-z") 'guix-switch-to-repl))))) (put 'guix-define-buffer-type 'lisp-indent-function 'defun) -;;; Messages - -(defvar guix-messages - '((package - (id - (0 "Packages not found.") - (1 "") - (many "%d packages." count)) - (name - (0 "The package '%s' not found." val) - (1 "A single package with name '%s'." val) - (many "%d packages with '%s' name." count val)) - (regexp - (0 "No packages matching '%s'." val) - (1 "A single package matching '%s'." val) - (many "%d packages matching '%s'." count val)) - (all-available - (0 "No packages are available for some reason.") - (1 "A single available package (that's strange).") - (many "%d available packages." count)) - (newest-available - (0 "No packages are available for some reason.") - (1 "A single newest available package (that's strange).") - (many "%d newest available packages." count)) - (installed - (0 "No installed packages.") - (1 "A single installed package.") - (many "%d installed packages." count)) - (obsolete - (0 "No obsolete packages.") - (1 "A single obsolete package.") - (many "%d obsolete packages." count)) - (generation - (0 "No packages installed in generation %d." val) - (1 "A single package installed in generation %d." val) - (many "%d packages installed in generation %d." count val))) - (generation - (id - (0 "Generations not found.") - (1 "") - (many "%d generations." count)) - (last - (0 "No available generations.") - (1 "The last generation.") - (many "%d last generations." count)) - (all - (0 "No available generations.") - (1 "A single available generation.") - (many "%d available generations." count))))) - -(defun guix-result-message (entries entry-type search-type search-vals) - "Display an appropriate message after displaying ENTRIES." - (let* ((val (car search-vals)) - (count (length entries)) - (count-key (if (> count 1) 'many count)) - (msg-spec (guix-get-key-val guix-messages - entry-type search-type count-key)) - (format (car msg-spec)) - (args (cdr msg-spec))) - (mapc (lambda (subst) - (setq args (cl-substitute (car subst) (cdr subst) args))) - (list (cons count 'count) - (cons val 'val))) - (apply #'message format args))) +;;; Getting 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) - -;;; Getting info about packages and generations +(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 (entry-type search-type search-vals &optional params) +(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' or -`generation'. +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': `id', `name', `regexp', +- 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'. +- 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 - 'get-entries - guix-current-profile params - entry-type search-type search-vals))) + '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)) + +(defun guix-manifest-file (profile &optional generation) + "Return the file name of a PROFILE's manifest. +If GENERATION number is specified, return manifest file name for +this generation." + (expand-file-name "manifest" + (if 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)) ;;; Actions on packages and generations +(defface guix-operation-option-key + '((t :inherit font-lock-warning-face)) + "Face used for the keys of operation options." + :group 'guix) + (defcustom guix-operation-confirm t "If nil, do not prompt to confirm an operation." :type 'boolean @@ -512,8 +773,57 @@ information with all available parameters." (defvar guix-temp-buffer-name " *Guix temp*" "Name of a buffer used for displaying info before executing operation.") -(defun guix-process-package-actions (&rest actions) - "Process package ACTIONS. +(defvar guix-operation-option-true-string "yes" + "String displayed in the mode-line when operation option is t.") + +(defvar guix-operation-option-false-string "no " + "String displayed in the mode-line when operation option is nil.") + +(defvar guix-operation-option-separator " | " + "String used in the mode-line to separate operation options.") + +(defvar guix-operation-options + '((?s "substitutes" guix-use-substitutes) + (?d "dry-run" guix-dry-run)) + "List of available operation options. +Each element of the list has a form: + + (KEY NAME VARIABLE) + +KEY is a character that may be pressed during confirmation to +toggle the option. +NAME is a string displayed in the mode-line. +VARIABLE is a name of an option variable.") + +(defun guix-operation-option-by-key (key) + "Return operation option by KEY (character)." + (assq key guix-operation-options)) + +(defun guix-operation-option-key (option) + "Return key (character) of the operation OPTION." + (car option)) + +(defun guix-operation-option-name (option) + "Return name of the operation OPTION." + (nth 1 option)) + +(defun guix-operation-option-variable (option) + "Return name of the variable of the operation OPTION." + (nth 2 option)) + +(defun guix-operation-option-value (option) + "Return boolean value of the operation OPTION." + (symbol-value (guix-operation-option-variable option))) + +(defun guix-operation-option-string-value (option) + "Convert boolean value of the operation OPTION to string and return it." + (if (guix-operation-option-value option) + guix-operation-option-true-string + guix-operation-option-false-string)) + +(defun guix-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 ...) @@ -531,25 +841,28 @@ PACKAGE-SPEC should have the following form: (ID [OUTPUT] ...)." ((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 guix-current-profile + 'process-package-actions profile :install install :upgrade upgrade :remove remove :use-substitutes? (or guix-use-substitutes 'f) - :dry-run? (or guix-dry-run 'f)))))) + :dry-run? (or guix-dry-run 'f)) + (and (not guix-dry-run) operation-buffer))))) -(cl-defun guix-continue-package-operation-p (&key install upgrade remove) +(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 - 'package 'id - (list (append (mapcar #'car install) - (mapcar #'car upgrade) - (mapcar #'car remove))) + 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)) @@ -560,6 +873,7 @@ See `guix-process-package-actions' for details." (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") @@ -568,7 +882,7 @@ See `guix-process-package-actions' for details." '((display-buffer-reuse-window display-buffer-at-bottom) (window-height . fit-window-to-buffer))))) - (prog1 (y-or-n-p "Continue operation? ") + (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)))) @@ -596,12 +910,157 @@ ENTRIES is a list of package entries to get info about packages." (defun guix-insert-package-strings (strings action) "Insert information STRINGS at point for performing package ACTION." (when strings - (insert "Package(s) to " (guix-get-string action 'bold) ":\n") + (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. +Ask a user with PROMPT for continuing an operation." + (let* ((option-keys (mapcar #'guix-operation-option-key + guix-operation-options)) + (keys (append '(?y ?n) option-keys)) + (prompt (concat (propertize (or prompt "Continue operation?") + 'face 'minibuffer-prompt) + " (" + (mapconcat + (lambda (key) + (propertize (string key) + 'face 'guix-operation-option-key)) + keys + ", ") + ") "))) + (let ((mode-line mode-line-format)) + (prog1 (guix-operation-prompt-1 prompt keys) + (setq mode-line-format mode-line) + ;; Clear the minibuffer after prompting. + (message ""))))) + +(defun guix-operation-prompt-1 (prompt keys) + "This function is internal for `guix-operation-prompt'." + (guix-operation-set-mode-line) + (let ((key (read-char-choice prompt (cons ?\C-g keys) t))) + (cl-case key + (?y t) + ((?n ?\C-g) nil) + (t (let* ((option (guix-operation-option-by-key key)) + (var (guix-operation-option-variable option))) + (set var (not (symbol-value var))) + (guix-operation-prompt-1 prompt keys)))))) + +(defun guix-operation-set-mode-line () + "Display operation options in the mode-line of the current buffer." + (setq mode-line-format + (concat (propertize " Options: " + 'face 'mode-line-buffer-id) + (mapconcat + (lambda (option) + (let ((key (guix-operation-option-key option)) + (name (guix-operation-option-name option)) + (val (guix-operation-option-string-value option))) + (concat name + " (" + (propertize (string key) + 'face 'guix-operation-option-key) + "): " val))) + guix-operation-options + guix-operation-option-separator))) + (force-mode-line-update)) + +(defun guix-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 ...") + (guix-eval-read + (guix-make-guile-expression + 'package-source-path package-id))) + +(defvar guix-after-source-download-hook nil + "Hook run after successful performing a 'source-download' operation.") + +(defun guix-package-source-build-derivation (package-id &optional prompt) + "Build source derivation of a package PACKAGE-ID. +Ask a user with PROMPT for continuing an operation." + (when (or (not guix-operation-confirm) + (guix-operation-prompt (or prompt + "Build the source derivation?"))) + (guix-eval-in-repl + (guix-make-guile-expression + 'package-source-build-derivation + package-id + :use-substitutes? (or guix-use-substitutes 'f) + :dry-run? (or guix-dry-run 'f)) + nil 'source-download))) + + +;;; Pull + +(defcustom guix-update-after-pull t + "If non-nil, update Guix buffers after performing \\[guix-pull]." + :type 'boolean + :group 'guix) + +(defvar guix-after-pull-hook + '(guix-restart-repl-after-pull guix-update-buffers-maybe-after-pull) + "Hook run after successful performing `guix-pull' operation.") + +(defun guix-restart-repl-after-pull () + "Restart Guix REPL after `guix-pull' operation." + (guix-repl-exit) + (guix-start-process-maybe + "Restarting Guix REPL after pull operation ...")) + +(defun guix-update-buffers-maybe-after-pull () + "Update buffers depending on `guix-update-after-pull'." + (when guix-update-after-pull + (mapc #'guix-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))) + (message "Guix buffers have been updated."))) + +;;;###autoload +(defun guix-pull (&optional verbose) + "Run Guix pull operation. +If VERBOSE is non-nil (with prefix argument), produce verbose output." + (interactive) + (let ((args (and verbose '("--verbose")))) + (guix-eval-in-repl + (apply #'guix-make-guile-expression 'guix-pull args) + nil 'pull))) + (provide 'guix-base) ;;; guix-base.el ends here