diff options
Diffstat (limited to 'emacs/guix-ui-package.el')
| -rw-r--r-- | emacs/guix-ui-package.el | 955 |
1 files changed, 955 insertions, 0 deletions
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 |