362 lines
16 KiB
EmacsLisp
362 lines
16 KiB
EmacsLisp
;;; helm-packages.el --- helm interface to manage packages -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2012 ~ 2023 Thierry Volpiatto
|
||
|
||
;; This program 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.
|
||
|
||
;; This program 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/>.
|
||
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'helm)
|
||
(require 'package)
|
||
(require 'finder)
|
||
(require 'helm-utils) ; For with-helm-display-marked-candidates.
|
||
(require 'async-package)
|
||
|
||
(declare-function dired-async-mode-line-message "ext:dired-async.el")
|
||
|
||
|
||
(defgroup helm-packages nil
|
||
"Helm interface for package.el."
|
||
:group 'helm)
|
||
|
||
(defclass helm-packages-class (helm-source-in-buffer)
|
||
((coerce :initform #'helm-symbolify)
|
||
(find-file-target :initform #'helm-packages-quit-an-find-file)
|
||
(filtered-candidate-transformer
|
||
:initform
|
||
'(helm-packages-transformer
|
||
(lambda (candidates _source)
|
||
(sort candidates #'helm-generic-sort-fn))))
|
||
(update :initform #'helm-packages--refresh-contents))
|
||
"A class to define `helm-packages' sources.")
|
||
|
||
(defcustom helm-packages-async t
|
||
"Install packages async when non nil."
|
||
:type 'boolean)
|
||
|
||
|
||
;;; Actions
|
||
;;
|
||
;;
|
||
(defun helm-packages-upgrade (_candidate)
|
||
"Helm action for upgrading marked packages."
|
||
(let ((mkd (helm-marked-candidates))
|
||
(error-file (expand-file-name
|
||
"helm-packages-upgrade-error.txt"
|
||
temporary-file-directory)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Upgrade %s packages? " (length mkd)))
|
||
(if helm-packages-async
|
||
(async-package-do-action 'upgrade mkd error-file)
|
||
(mapc #'package-upgrade mkd))))))
|
||
|
||
(defun helm-packages-describe (candidate)
|
||
"Helm action for describing package CANDIDATE."
|
||
(describe-package candidate))
|
||
|
||
(defun helm-packages-visit-homepage (candidate)
|
||
"Helm action for visiting package CANDIDATE home page."
|
||
(let* ((id (package-get-descriptor candidate))
|
||
(name (package-desc-name id))
|
||
(extras (package-desc-extras id))
|
||
(url (and (listp extras) (cdr-safe (assoc :url extras)))))
|
||
(if (stringp url)
|
||
(browse-url url)
|
||
(message "Package %s has no homepage"
|
||
(propertize (symbol-name name)
|
||
'face 'font-lock-keyword-face)))))
|
||
|
||
(defun helm-packages-package-reinstall (_candidate)
|
||
"Helm action for reinstalling marked packages."
|
||
(let ((mkd (helm-marked-candidates))
|
||
(error-file (expand-file-name
|
||
"helm-packages-reinstall-error.txt"
|
||
temporary-file-directory)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Reinstall %s packages? " (length mkd)))
|
||
(if helm-packages-async
|
||
(async-package-do-action 'reinstall mkd error-file)
|
||
(mapc #'package-reinstall mkd))))))
|
||
|
||
(defun helm-packages-delete-1 (packages &optional force)
|
||
"Run `package-delete' on PACKAGES.
|
||
If FORCE is non nil force deleting packages."
|
||
(mapc (lambda (x)
|
||
(package-delete (package-get-descriptor x) force))
|
||
packages))
|
||
|
||
(defun helm-packages-uninstall (_candidate)
|
||
"Helm action for uninstalling marked packages.
|
||
Unlike `helm-packages-delete' this will refuse to delete packages when they are
|
||
needed by others packages as dependencies."
|
||
(let ((mkd (helm-marked-candidates)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Uninstall %s packages? " (length mkd)))
|
||
(helm-packages-delete-1 mkd)))))
|
||
|
||
(defun helm-packages-delete (_candidate)
|
||
"Helm action for deleting marked packages.
|
||
Unlike `helm-packages-uninstall' this delete packages even when they are needed
|
||
as dependencies."
|
||
(let ((mkd (helm-marked-candidates)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Delete %s packages? " (length mkd)))
|
||
(helm-packages-delete-1 mkd 'force)))))
|
||
|
||
(defun helm-packages-recompile (_candidate)
|
||
"Helm action for recompiling marked packages."
|
||
(let ((mkd (helm-marked-candidates)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Recompile %s packages? " (length mkd)))
|
||
(mapc #'package-recompile mkd)))))
|
||
|
||
(defun helm-packages-install--sync (packages)
|
||
(condition-case err
|
||
(mapc #'package-install packages)
|
||
(error "%S:\n Please refresh package list before installing" err)))
|
||
|
||
(defun helm-packages-install (_candidate)
|
||
"Helm action for installing marked packages."
|
||
(let ((mkd (helm-marked-candidates))
|
||
(error-file (expand-file-name
|
||
"helm-packages-install-error.txt"
|
||
temporary-file-directory)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
(mapcar #'symbol-name mkd)
|
||
(when (y-or-n-p (format "Install %s packages? " (length mkd)))
|
||
(if helm-packages-async
|
||
(async-package-do-action 'install mkd error-file)
|
||
(helm-packages-install--sync mkd))))))
|
||
|
||
(defun helm-packages-isolate-1 (packages)
|
||
"Start an Emacs with only PACKAGES loaded.
|
||
Arg PACKAGES is a list of strings."
|
||
(let* ((name (concat "package-isolate-" (mapconcat #'identity packages "_")))
|
||
(deps (cl-loop for p in packages
|
||
for sym = (intern p)
|
||
nconc (package--dependencies sym))))
|
||
(apply #'start-process name nil
|
||
(list (expand-file-name invocation-name invocation-directory)
|
||
"-Q" "--debug-init"
|
||
(format "--eval=%S"
|
||
`(progn
|
||
(require 'package)
|
||
(setq package-load-list
|
||
',(append (mapcar (lambda (p) (list (intern p) t))
|
||
packages)
|
||
(mapcar (lambda (p) (list p t)) deps)))
|
||
(package-initialize)))))))
|
||
|
||
(defun helm-packages-isolate (_candidate)
|
||
"Start a new Emacs with only marked packages loaded."
|
||
(let* ((mkd (helm-marked-candidates))
|
||
(pkg-names (mapcar #'symbol-name mkd))
|
||
(isolate (if (fboundp 'package-isolate)
|
||
#'package-isolate
|
||
#'helm-packages-isolate-1)))
|
||
(with-helm-display-marked-candidates
|
||
helm-marked-buffer-name
|
||
pkg-names
|
||
(when (y-or-n-p "Start a new Emacs with only package(s)? ")
|
||
(funcall isolate pkg-names)))))
|
||
|
||
(defun helm-packages-quit-an-find-file (source)
|
||
"`find-file-target' function for `helm-packages'."
|
||
(let* ((sel (helm-get-selection nil nil source))
|
||
(pkg (package-get-descriptor (intern sel))))
|
||
(if (and pkg (package-installed-p pkg))
|
||
(expand-file-name (package-desc-dir pkg))
|
||
package-user-dir)))
|
||
|
||
;;; Transformers
|
||
;;
|
||
;;
|
||
(defun helm-packages-transformer (candidates _source)
|
||
"Transformer function for `helm-packages'."
|
||
(cl-loop for c in candidates
|
||
for sym = (intern-soft c)
|
||
for archive = (assq sym package-archive-contents)
|
||
for id = (package-get-descriptor sym)
|
||
for provider = (and archive (package-desc-archive (cadr archive)))
|
||
for status = (and id (package-desc-status id))
|
||
for version = (and id (mapconcat #'number-to-string (package-desc-version id) "."))
|
||
for description = (and id (package-desc-summary id))
|
||
for disp = (format "%s%s%s%s%s%s%s%s%s"
|
||
;; Package name.
|
||
(propertize
|
||
c
|
||
'face
|
||
(helm-acase status
|
||
("dependency" 'font-lock-type-face)
|
||
("disabled" 'default)
|
||
(t 'font-lock-keyword-face))
|
||
'match-part c)
|
||
;; Separator.
|
||
(make-string (1+ (- (helm-in-buffer-get-longest-candidate)
|
||
(length c)))
|
||
? )
|
||
;; Package status.
|
||
(propertize
|
||
(or status "")
|
||
'face (helm-acase status
|
||
("dependency" 'bold-italic)
|
||
("disabled" 'font-lock-property-name-face)
|
||
(t 'default)))
|
||
;; Separator.
|
||
(make-string (1+ (- 10 (length status))) ? )
|
||
;; Package provider.
|
||
(or provider "")
|
||
;; Separator.
|
||
(make-string (1+ (- 10 (length provider))) ? )
|
||
;; Package version.
|
||
(or version "")
|
||
;; Separator.
|
||
(make-string (1+ (- 20 (length version))) ? )
|
||
;; Package description.
|
||
(if description
|
||
(propertize description 'face 'font-lock-warning-face)
|
||
""))
|
||
collect (cons disp c)))
|
||
|
||
(defun helm-packages-transformer-1 (candidates _source)
|
||
"Transformer function for `helm-packages' upgrade and delete sources."
|
||
(cl-loop for c in candidates
|
||
collect (cons (propertize c 'face 'font-lock-keyword-face) c)))
|
||
|
||
(defvar helm-packages--updated nil)
|
||
(defun helm-packages--refresh-contents ()
|
||
(unless helm-packages--updated (package-refresh-contents))
|
||
(helm-set-local-variable 'helm-packages--updated t))
|
||
|
||
(defun helm-finder--list-matches (key)
|
||
(let* ((id (intern key))
|
||
(packages (gethash id finder-keywords-hash)))
|
||
(unless packages
|
||
(error "No packages matching key `%s'" key))
|
||
packages))
|
||
|
||
|
||
;;;###autoload
|
||
(defun helm-packages (&optional arg)
|
||
"Helm interface to manage packages.
|
||
|
||
With a prefix arg ARG refresh package list.
|
||
|
||
When installing or upgrading ensure to refresh the package list
|
||
to avoid errors with outdated packages no more availables."
|
||
(interactive "P")
|
||
(package-initialize)
|
||
(when arg (helm-packages--refresh-contents))
|
||
(let ((upgrades (cl-loop for p in (package--upgradeable-packages)
|
||
unless (helm-aand (assq p package-load-list)
|
||
(or (null (cadr it)) (stringp (cadr it))))
|
||
collect p))
|
||
(removables (package--removable-packages)))
|
||
(helm :sources (list
|
||
(helm-make-source "Availables for upgrade" 'helm-packages-class
|
||
:init (lambda ()
|
||
(helm-init-candidates-in-buffer 'global upgrades))
|
||
:filtered-candidate-transformer #'helm-packages-transformer-1
|
||
:action '(("Upgrade package(s)"
|
||
. helm-packages-upgrade)))
|
||
(helm-make-source "Packages to delete" 'helm-packages-class
|
||
:init (lambda ()
|
||
(helm-init-candidates-in-buffer 'global removables))
|
||
:filtered-candidate-transformer #'helm-packages-transformer-1
|
||
:action '(("Delete package(s)" . helm-packages-delete)))
|
||
(helm-make-source "Installed packages" 'helm-packages-class
|
||
:init (lambda ()
|
||
(helm-init-candidates-in-buffer 'global
|
||
(mapcar #'car package-alist)))
|
||
:action '(("Describe package" . helm-packages-describe)
|
||
("Visit homepage" . helm-packages-visit-homepage)
|
||
("Reinstall package(s)"
|
||
. helm-packages-package-reinstall)
|
||
("Recompile package(s)" . helm-packages-recompile)
|
||
("Uninstall package(s)" . helm-packages-uninstall)
|
||
("Isolate package(s)" . helm-packages-isolate)))
|
||
(helm-make-source "Available external packages" 'helm-packages-class
|
||
:data (cl-loop for p in package-archive-contents
|
||
for sym = (car p)
|
||
for id = (package-get-descriptor sym)
|
||
for status = (package-desc-status id)
|
||
unless (or (and id (member
|
||
status
|
||
'("installed" "dependency" "source")))
|
||
(and id (assoc sym package--builtins)))
|
||
nconc (list (car p)))
|
||
:action '(("Describe package" . helm-packages-describe)
|
||
("Visit homepage" . helm-packages-visit-homepage)
|
||
("Install packages(s)"
|
||
. helm-packages-install)))
|
||
(helm-make-source "Available built-in packages" 'helm-packages-class
|
||
:data (cl-loop for p in package--builtins
|
||
;; Show only builtins that are available as
|
||
;; well on (m)elpa. Other builtins don't
|
||
;; have a package-descriptor, the format is
|
||
;; (sym . [version reqs summary]).
|
||
when (package-desc-p (package-get-descriptor (car p)))
|
||
collect (car p))
|
||
:action '(("Describe package" . helm-packages-describe)
|
||
("Visit homepage" . helm-packages-visit-homepage)
|
||
("Install packages(s)"
|
||
. helm-packages-install))))
|
||
:buffer "*helm packages*")))
|
||
|
||
;;;###autoload
|
||
(defun helm-finder ()
|
||
"Helm interface to find packages by keywords with `finder'."
|
||
(interactive)
|
||
(helm :sources
|
||
(helm-build-in-buffer-source "helm finder"
|
||
:data (mapcar #'car finder-known-keywords)
|
||
:filtered-candidate-transformer
|
||
(lambda (candidates _source)
|
||
(cl-loop for cand in candidates
|
||
for desc = (assoc-default (intern-soft cand) finder-known-keywords)
|
||
for sep = (helm-make-separator cand)
|
||
for disp = (helm-aand (propertize desc 'face 'font-lock-warning-face)
|
||
(propertize " " 'display (concat sep it))
|
||
(concat cand it))
|
||
collect (cons disp cand)))
|
||
:action (lambda (c)
|
||
(if (string-match "\\.el$" c)
|
||
(finder-commentary c)
|
||
(helm :sources
|
||
(helm-make-source "packages" 'helm-packages-class
|
||
:init (lambda ()
|
||
(helm-init-candidates-in-buffer
|
||
'global (helm-finder--list-matches c)))
|
||
:filtered-candidate-transformer #'helm-packages-transformer-1
|
||
:action '(("Describe package" . helm-packages-describe)))
|
||
:buffer "*helm finder results*"))))
|
||
:buffer "*helm finder*"))
|
||
|
||
(provide 'helm-packages)
|
||
|
||
;;; helm-packages ends here
|