From 4d6737ac59b3d9319a8d94b45ab514d92bd771e4 Mon Sep 17 00:00:00 2001 From: Philip K Date: Thu, 11 Feb 2021 16:30:09 +0100 Subject: [PATCH] Add package-suggest-configuration --- lisp/emacs-lisp/package.el | 154 +++++++++++++++++++++++++++++++++---- 1 file changed, 140 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 90b7b88d58..a7c957dccd 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -146,7 +146,9 @@ (require 'cl-lib) (eval-when-compile (require 'subr-x)) (eval-when-compile (require 'epg)) ;For setf accessors. +(eval-when-compile (require 'pcase)) (require 'seq) +(require 'rmc) (require 'tabulated-list) (require 'macroexp) @@ -424,6 +426,13 @@ package-archive-column-width :type 'number :version "28.1") +(defcustom package-query-suggestions nil + "How to treat configuration suggestions by packages. +If non-nil, ask the user if they are interested in what a package +has to suggest. Otherwise ignore the suggestions." + :type 'boolean + :version "28.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -2087,6 +2096,135 @@ package--archives-initialize (unless package-archive-contents (package-refresh-contents))) +(defvar pacakge-configuration-suggestions nil + "An alist of advertised default configuration. +Each entry has the form (PACKAGE . SUGGESTIONS), where PACAKGE is a +symbol designating the package, and SUGGESTIONS is another alist. +SUGGESTIONS have the form (TYPE EXPLAIN . DATA), where TYPE says +what kind of a suggestion is being made, EXPLAIN is a string that +legitimatises the suggestion and DATA is the content of the +suggestion. Currently, the following values for TYPE are +understood: + +- `key', where DATA has the form (KEY FUNCTION). It suggests + binding FUNCTION globally to KEY, unless KEY is already bound. + KEY is passed to the function `kbd'. + +- `option', where DATA has the form (OPT VAL). It setting the + symbol OPT to the value VAL. + +- `hook', where DATA has the form (HOOK FUNCTION). It suggests + adding FUNCTION to the hook HOOK. + +All other values for TYPE are ignored.") + +(defun package--query-name (&optional kind verb) + "Query the user for a package name. +If KIND is nil, prompt for all kinds of packages. If KIND is +`installed' only prompt for installed packages. If KIND is +`not-installed', only prompt for packages that have not been +installed. VERB modified to prompt." + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (intern (completing-read + (format "%s package: " (or verb "Select")) + (delq nil (mapcar (lambda (elt) + (when (cond + ((eq kind 'installed) + (package-installed-p (car elt))) + ((eq kind 'not-installed) + (not (package-installed-p (car elt)))) + ((null kind)) + (t (error "Invalid kind"))) + (symbol-name (car elt)))) + package-archive-contents)) + nil t))) + +(defun package--show-explanation (doc) + "Show explanation DOC in a help buffer." + (ignore-errors (kill-buffer "*explain*")) + (with-current-buffer (get-buffer-create "*explain*") + (erase-buffer) + (with-help-window (current-buffer) + (princ (substitute-command-keys doc))))) + +(defun package-suggest-configuration (package &optional preview) + "Query the user to automatically configure PACKAGE. +If PREVIEW is non-nil, do not save and load the new +customization." + (interactive (list (package--query-name 'installed) current-prefix-arg)) + (when (or (called-interactively-p 'any) package-query-suggestions) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (unless (cdr (assq package pacakge-configuration-suggestions)) + (message "Nothing to configure.")) + (dolist (sug (cdr (assq package pacakge-configuration-suggestions))) + (terpri nil t) + (save-window-excursion ;restore explain buffers + (pcase sug + (`(key ,explain ,key ,command) + (unless (or (where-is-internal command) (key-binding key)) + (let ((key (cl-loop + for ch = (read-multiple-choice + (format "%s suggests binding `%s' to %s. Do you want to bind it? " + package command (key-description key)) + '((?y "yes" "Bind command to the suggested key") + (?n "no" "Ignore the suggestion") + (?e "explain" "Ask the package why is suggests this") + (?o "other" "Bind key to a different key"))) + when (eq (car ch) ?y) return key + when (eq (car ch) ?n) return nil + when (eq (car ch) ?e) do (package--show-explanation explain) + when (eq (car ch) ?o) do + (let* ((alt (read-key-sequence "Bind to: " )) + (bound (key-binding alt))) + (if (not bound) + (cl-return alt) + (message "%s is already bound to %s" + (key-description alt) + (key-binding alt)) + (sit-for 2)))))) + (when key + (prin1 `(global-set-key + (kbd ,(key-description key)) + #',command)))))) + (`(option ,explain ,option ,value) + (when (cl-loop + for ch = (read-multiple-choice + (format "%s suggests setting the option `%s' to %s. Do you want to set it? " + package option value) + '((?y "yes" "Set the option") + (?n "no" "Ignore the suggestion") + (?e "explain" "Ask the package why is suggests this"))) + when (eq (car ch) ?y) return t + when (eq (car ch) ?n) return nil + when (eq (car ch) ?e) do (package--show-explanation explain)) + (prin1 `(customize-set-variable ',option ,value)))) + (`(hook ,explain ,hook ,function) + (when (cl-loop + for ch = (read-multiple-choice + (format "%s suggests adding `%s' to %s. Do you want to add it? " + package function hook) + '((?y "yes" "Add to hook") + (?n "no" "Ignore the suggestion") + (?e "explain" "Ask the package why is suggests this"))) + when (eq (car ch) ?y) return t + when (eq (car ch) ?n) return nil + when (eq (car ch) ?e) do (package--show-explanation explain)) + (prin1 `(add-hook ',hook #',function))))))) + (when (/= (point-min) (point-max)) + (if preview + (let ((buf (get-buffer-create (format "*suggested configuration for %s*" + package)))) + (with-current-buffer buf + (emacs-lisp-mode)) + (copy-to-buffer buf (point-min) (point-max)) + (pop-to-buffer buf)) + (eval-buffer) + (append-to-file (point-min) (point-max) + (or custom-file user-init-file)))))))) + ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. @@ -2103,20 +2241,7 @@ package-install If PKG is a `package-desc' and it is already installed, don't try to install it but still mark it as selected." - (interactive - (progn - ;; Initialize the package system to get the list of package - ;; symbols for completion. - (package--archives-initialize) - (list (intern (completing-read - "Install package: " - (delq nil - (mapcar (lambda (elt) - (unless (package-installed-p (car elt)) - (symbol-name (car elt)))) - package-archive-contents)) - nil t)) - nil))) + (interactive (list (package--query-name 'not-installed "Install"))) (package--archives-initialize) (add-hook 'post-command-hook #'package-menu--post-refresh) (let ((name (if (package-desc-p pkg) @@ -2134,6 +2259,7 @@ package-install (progn (package-download-transaction transaction) (package--quickstart-maybe-refresh) + (with-local-quit (package-suggest-configuration pkg)) (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) -- 2.29.2