[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/racket-mode 6d31d035db 3/3: Add list-racket-packages and d
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/racket-mode 6d31d035db 3/3: Add list-racket-packages and describe-racket-package |
|
Date: |
Mon, 15 Jul 2024 13:00:45 -0400 (EDT) |
branch: elpa/racket-mode
commit 6d31d035db555c661c1fc53aa1400be2d4917278
Author: Greg Hendershott <git@greghendershott.com>
Commit: Greg Hendershott <git@greghendershott.com>
Add list-racket-packages and describe-racket-package
Issue #710 planted the idea.
Largely follow the UX used by Emacs for its list-packages (a tabulated
list view) and describe-package (a help buffer with details).
In latter, "link all the things": can visit paths, URLs, and details
of dependency packages.
Append some general package system configuration. On the one hand this
is weird, because the information is not details about a specific
package. On the other hand, we distinguish it in the UX, and it seems
easier (for users) to see it there than needing to discover and issue
some additional command.
Support package names as a distinct 'racket-package completion
category, both to avoid things like marginalia mistakenly classifying
and annotating our choices, as well as to allow users to customize
completion styles.
Do package operations in each back end, to support a mix of Racket
version installations, both remote and local.
---
doc/generate.el | 5 +
doc/racket-mode.texi | 89 ++++++++++
racket-cmd.el | 5 +
racket-complete.el | 15 +-
racket-hash-lang.el | 2 +
racket-mode.el | 2 +
racket-package.el | 433 ++++++++++++++++++++++++++++++++++++++++++++++
racket-xp-complete.el | 3 +-
racket/command-server.rkt | 8 +-
racket/package.rkt | 325 ++++++++++++++++++++++++++++++++++
racket/scribble.rkt | 35 +++-
11 files changed, 909 insertions(+), 13 deletions(-)
diff --git a/doc/generate.el b/doc/generate.el
index 17a91e7b8f..8b4287a207 100644
--- a/doc/generate.el
+++ b/doc/generate.el
@@ -20,6 +20,7 @@
(require 'racket-smart-open)
(require 'racket-repl-buffer-name)
(require 'racket-hash-lang)
+(require 'racket-package)
(require 'seq)
(defun racket-generate-reference.org ()
@@ -106,6 +107,10 @@
racket-expand-region
racket-expand-definition
racket-expand-last-sexp
+ "Packages"
+ list-racket-packages
+ racket-package-mode
+ describe-racket-package
"Other"
racket-debug-toggle-breakpoint
racket-mode-start-faster
diff --git a/doc/racket-mode.texi b/doc/racket-mode.texi
index ecde865a85..8ca768b3d4 100644
--- a/doc/racket-mode.texi
+++ b/doc/racket-mode.texi
@@ -90,6 +90,7 @@ Commands
* Eval::
* Collections::
* Macro expand::
+* Packages::
* Other::
Edit
@@ -180,6 +181,12 @@ Macro expand
* racket-expand-definition::
* racket-expand-last-sexp::
+Packages
+
+* list-racket-packages::
+* racket-package-mode::
+* describe-racket-package::
+
Other
* racket-debug-toggle-breakpoint::
@@ -920,6 +927,7 @@ You can also view these by using the normal Emacs help
mechanism:
* Eval::
* Collections::
* Macro expand::
+* Packages::
* Other::
@end menu
@@ -2862,6 +2870,87 @@ Uses the @code{macro-debugger} package to do the
expansion.
With @kbd{C-u} behaves as if @ref{racket-expand-hiding}
were 'disabled.
+@node Packages
+@section Packages
+
+@menu
+* list-racket-packages::
+* racket-package-mode::
+* describe-racket-package::
+@end menu
+
+@node list-racket-packages
+@subsection list-racket-packages
+
+@kbd{M-x} @code{list-racket-packages}
+
+Open a @ref{racket-package-mode} buffer for the active back end.
+
+@node racket-package-mode
+@subsection racket-package-mode
+
+@kbd{M-x} @code{racket-package-mode}
+
+Major mode for Racket package management.
+
+The list of packages is equivalent to ``raco pkg show -all'' on
+the active back end.
+
+On each row you can press RET to @code{describe-racket-package}, which
+opens a buffer where you can view details, and use buttons to
+install/update/remove the package.
+
+@multitable {aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa}
{aaaaaaaaaaaaaaaaaaaaaaaaa}
+@item Key
+@tab Binding
+@item @kbd{RET}
+@tab @code{racket-package-describe}
+@end multitable
+
+
+
+
+In addition to any hooks its parent mode @code{tabulated-list-mode} might
+have run, this mode runs the hook @code{racket-package-mode-hook}, as the
+final or penultimate step during initialization.
+
+@node describe-racket-package
+@subsection describe-racket-package
+
+@kbd{M-x} @code{describe-racket-package}
+
+Describe details of a Racket package.
+
+Depending on the package status, buttons let you install, update,
+and/or remove the package and its dependencies. These convenience
+buttons are equivalent to using the command line on the active
+back end to do ``raco pkg @{install update remove@} --auto''. For
+other operations, you still need to use ``raco pkg'' yourself;
+see @uref{https://docs.racket-lang.org/pkg/cmdline.html}.
+
+Detail values are links when possible:
+
+@itemize
+@item
+The @emph{Catalog} (when ``@uref{https://pkgs.racket-lang.org}'') links to
+the package's web page, which may have additional details not
+available locally.
+
+@item
+The @emph{Source} links to the repo's web page or local filesystem.
+
+@item
+The @emph{Directory} for an installed package opens a dired buffer.
+
+@item
+Each @emph{Dependencies} name links to details about that package.
+
+@item
+For installed packages, each @emph{Modules} item links to the local
+file. There is also a button to each module's locally installed
+documentation, if any.
+@end itemize
+
@node Other
@section Other
diff --git a/racket-cmd.el b/racket-cmd.el
index 9c416aa955..6723da554f 100644
--- a/racket-cmd.el
+++ b/racket-cmd.el
@@ -30,6 +30,9 @@
(declare-function racket--repl-on-output "racket-repl" (session-id kind
value))
(autoload 'racket--repl-on-output "racket-repl")
+(declare-function racket--package-on-notify "racket-package" (v))
+(autoload 'racket--package-on-notify "racket-package")
+
;;;###autoload
(defvar racket-start-back-end-hook nil
"Hook run after `racket-start-back-end' finishes successfully.")
@@ -219,6 +222,8 @@ notifications."
(run-at-time 0.001 nil #'racket--hash-lang-on-notify id vs))
(`(repl-output ,session-id ,kind ,v)
(run-at-time 0.001 nil #'racket--repl-on-output session-id kind v))
+ (`(pkg-op-notify . ,v)
+ (run-at-time 0.001 nil #'racket--package-on-notify v))
(`(,nonce . ,response)
(when-let (callback (gethash nonce racket--cmd-nonce->callback))
(remhash nonce racket--cmd-nonce->callback)
diff --git a/racket-complete.el b/racket-complete.el
index cc8dd2509f..797b3b628d 100644
--- a/racket-complete.el
+++ b/racket-complete.el
@@ -56,10 +56,10 @@
(add-to-list 'completion-category-defaults
`(,racket--identifier-category (styles basic)))
-(defun racket--completion-table (completions &optional category)
- "Like `completion-table-dynamic' but we supply category metadata.
+(defun racket--completion-table (completions &optional metadata)
+ "Like `completion-table-dynamic' but also metadata.
-CATEGORY defaults to `racket--identifier-category'.
+METADATA defaults to `((category . ,`racket--identifier-category')).
Category metadata needs to be returned by the completion table
function itself, unlike metadata supplied as properties in the
@@ -67,11 +67,10 @@ function itself, unlike metadata supplied as properties in
the
Supplying category metadata allows the user to configure a
completion matching style for that category."
- (let ((category (or category racket--identifier-category)))
- (lambda (prefix predicate action)
- (if (eq action 'metadata)
- `(metadata (category . ,category))
- (complete-with-action action completions prefix predicate)))))
+ (lambda (prefix predicate action)
+ (if (eq action 'metadata)
+ (cons 'metadata (or metadata `((category .
,racket--identifier-category))))
+ (complete-with-action action completions prefix predicate))))
(provide 'racket-complete)
diff --git a/racket-hash-lang.el b/racket-hash-lang.el
index 4eb8d7ce05..d7ae192673 100644
--- a/racket-hash-lang.el
+++ b/racket-hash-lang.el
@@ -88,6 +88,8 @@
"---"
["Next Error or Link" next-error]
["Previous Error" previous-error]
+ "---"
+ ["List Racket Packages" list-racket-packages]
["Customize..." customize-mode]))
(defvar-local racket--hash-lang-submit-predicate-p nil)
diff --git a/racket-mode.el b/racket-mode.el
index d995ee2591..1023149063 100644
--- a/racket-mode.el
+++ b/racket-mode.el
@@ -29,6 +29,7 @@
(require 'racket-custom)
(require 'racket-smart-open)
(require 'racket-imenu)
+(require 'racket-package)
(require 'racket-profile)
(require 'racket-logger)
(require 'racket-shell)
@@ -121,6 +122,7 @@
["Trim Requires" racket-trim-requires]
["Use #lang racket/base" racket-base-requires]
"---"
+ ["List Racket Packages" list-racket-packages]
["Start Faster" racket-mode-start-faster]
["Customize..." customize-mode]))
diff --git a/racket-package.el b/racket-package.el
new file mode 100644
index 0000000000..e80805f9fd
--- /dev/null
+++ b/racket-package.el
@@ -0,0 +1,433 @@
+;;; racket-package.el -*- lexical-binding: t -*-
+
+;; Copyright (c) 2024 by Greg Hendershott.
+;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
+
+;; Author: Greg Hendershott
+;; URL: https://github.com/greghendershott/racket-mode
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+(require 'seq)
+(require 'url-parse)
+(require 'racket-complete)
+(require 'racket-custom)
+(require 'racket-browse-url)
+(require 'racket-back-end)
+(require 'racket-cmd)
+(require 'xref)
+
+;;; racket-package-mode summary list of packages
+
+(defun racket--package-buffer-name ()
+ (format "*Racket Packages <%s>*" (racket-back-end-name)))
+
+;;;###autoload
+(defun list-racket-packages ()
+ "Open a `racket-package-mode' buffer for the active back end."
+ (interactive)
+ (with-current-buffer (get-buffer-create (racket--package-buffer-name))
+ (unless (eq major-mode 'racket-package-mode)
+ (racket-package-mode))
+ (pop-to-buffer (current-buffer))
+ (tabulated-list-init-header)
+ (tabulated-list-print)))
+
+(defvar racket-package-mode-map
+ (let ((m (make-sparse-keymap)))
+ (set-keymap-parent m nil)
+ (mapc (lambda (x)
+ (define-key m (kbd (car x)) (cadr x)))
+ `(("RET" ,#'racket-package-describe)))
+ m)
+ "Keymap for `racket-package-mode'.")
+
+(define-derived-mode racket-package-mode tabulated-list-mode
+ "Racket Package List"
+ "Major mode for Racket package management.
+
+The list of packages is equivalent to \"raco pkg show -all\" on
+the active back end.
+
+On each row you can press RET to `describe-racket-package', which
+opens a buffer where you can view details, and use buttons to
+install/update/remove the package.
+
+\\{racket-package-mode-map}
+"
+ (setq show-trailing-whitespace nil)
+ (setq tabulated-list-sort-key '("Name" . nil))
+ (setq tabulated-list-padding 0)
+ (setq tabulated-list-format
+ `[("Name" 20 t)
+ ("Status" 10 t)
+ ("Description" 15 t)])
+ (setq tabulated-list-entries
+ #'racket-package-tabulated-list-entries))
+
+(defun racket-package-tabulated-list-entries ()
+ (seq-map (lambda (summary)
+ (pcase-let* ((`(,name ,status ,desc) summary)
+ (status-face (pcase status
+ ("available"
'package-status-available)
+ (_
'package-status-installed))))
+ (list name
+ (vector (list name
+ :type 'describe-racket-package
+ 'face 'package-name)
+ (propertize status
+ 'font-lock-face status-face)
+ desc))))
+ (racket--cmd/await nil `(pkg-list))))
+
+;;; help buffer of details about a single package, and button actions
+
+(defun racket-package-describe ()
+ "`describe-racket-package' the package at point."
+ (interactive)
+ (describe-racket-package (tabulated-list-get-id)))
+
+(define-button-type 'describe-racket-package
+ 'action #'describe-racket-package)
+
+;;;###autoload
+(defun describe-racket-package (&optional name-or-button)
+ "Describe details of a Racket package.
+
+Depending on the package status, buttons let you install, update,
+and/or remove the package and its dependencies. These convenience
+buttons are equivalent to using the command line on the active
+back end to do \"raco pkg {install update remove} --auto\". For
+other operations, you still need to use \"raco pkg\" yourself;
+see <https://docs.racket-lang.org/pkg/cmdline.html>.
+
+Detail values are links when possible:
+
+- The /Catalog/ (when \"https://pkgs.racket-lang.org\";) links to
+ the package's web page, which may have additional details not
+ available locally.
+
+- The /Source/ links to the repo's web page or local filesystem.
+
+- The /Directory/ for an installed package opens a dired buffer.
+
+- Each /Dependencies/ name links to details about that package.
+
+- For installed packages, each /Modules/ item links to the local
+ file. There is also a button to each module's locally installed
+ documentation, if any."
+ (interactive (racket--package-completing-read))
+ (let ((name (if name-or-button
+ (if (stringp name-or-button)
+ name-or-button
+ (button-label name-or-button))
+ (tabulated-list-get-id))))
+ (unless name (user-error "no package"))
+ (racket--cmd/async
+ nil
+ `(pkg-details ,name)
+ (lambda (details)
+ (help-setup-xref (list #'describe-racket-package (alist-get 'name
details))
+ (called-interactively-p 'interactive))
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (racket--package-insert-details details)))))))
+
+(defvar racket-package-history nil
+ "History for `describe-racket-package'.")
+
+(defconst racket-package-completion-category 'racket-package
+ "Completion category for Racket package names.
+Allows users to customize via `completion-category-overrides'.")
+
+(defun racket--package-completing-read ()
+ "Arrange for :category and :affixation-function to show metadata."
+ (pcase-let*
+ ((pkgs (racket--cmd/await nil `(pkg-list)))
+ ;; Find longest name and stat values, for use by
+ ;; affixation-function to align items.
+ (`(,max-name . ,max-stat)
+ (seq-reduce (pcase-lambda (`(,max-name . ,max-stat)
+ `(,name ,stat ,_desc))
+ (cons (max max-name (1+ (length name)))
+ (max max-stat (1+ (length stat)))))
+ pkgs
+ (cons 0 0)))
+ (affix
+ (lambda (vs)
+ (seq-map
+ (lambda (v)
+ (pcase (assoc v pkgs)
+ (`(,name ,stat ,desc)
+ (list v
+ ""
+ (propertize
+ (concat (make-string (- max-name (length name)) 32)
+ stat
+ (make-string (- max-stat (length stat)) 32)
+ desc)
+ 'face 'font-lock-comment-face)))))
+ vs)))
+ (val (completing-read "Describe Racket package: "
+ (racket--completion-table
+ pkgs
+ `((category .
,racket-package-completion-category)
+ (affixation-function . ,affix)))
+ nil nil nil
+ 'racket-package-history nil)))
+ (list (and (> (length val) 0) val))))
+
+(defconst racket--package-main-catalog
+ "https://pkgs.racket-lang.org";)
+
+(defun racket--package-insert-details (details)
+ (let ((name (alist-get 'name details))
+ (status (alist-get 'status details)))
+ (insert (propertize name
+ 'font-lock-face 'bold))
+ (pcase status
+ ("available"
+ (insert " is available to ")
+ (racket--package-insert-raco-pkg-op-button 'install name)
+ (when (equal (alist-get 'catalog details)
+ racket--package-main-catalog)
+ (insert "; ")
+ (insert-text-button "documentation"
+ :type 'racket-package-check-doc
+ 'racket-package-name name)))
+ ("manual"
+ (insert " was manually installed: ")
+ (racket--package-insert-raco-pkg-op-button 'update name)
+ (insert " or ")
+ (racket--package-insert-raco-pkg-op-button 'remove name))
+ ("dependency"
+ (insert " was automatically installed as a dependency"))
+ (_
+ (insert " is ")
+ (insert status)))
+ (newline)
+ (newline)
+ (let ((lks `((" Description" description)
+ (" Directory" dir)
+ (" Scope" scope)
+ (" Source" source)
+ (" Catalog" catalog)
+ (" Checksum" checksum)
+ (" Author" author)
+ (" Tags" tags)
+ ("Dependencies" deps)
+ (" Modules" modules)
+ ;; configuration
+ (" Name" config-name)
+ (" Default Scope" default-scope)
+ (" Catalogs" config-catalogs))))
+ (dolist (lk lks)
+ (pcase-let ((`(,l ,k) lk))
+ (when-let (v (alist-get k details))
+ (when (eq k 'config-name)
+ (insert (propertize "\n--- raco pkg configure
------------------\n"
+ 'font-lock-face 'font-lock-comment-face)))
+
+ (insert (propertize (concat l ":")
+ 'font-lock-face 'package-help-section-name))
+ (pcase k
+ ('deps
+ (let ((firstp t))
+ (dolist (dep v)
+ (if firstp
+ (progn (setq firstp nil) (insert " "))
+ (insert "\n "))
+ (insert-text-button (car dep)
+ :type 'describe-racket-package)
+ (insert " ")
+ (insert (cdr dep))))
+ (newline))
+ ('catalog
+ (insert " ")
+ (if (equal v "https://pkgs.racket-lang.org";)
+ (insert-text-button v
+ :type 'racket-package-browse-url
+ 'url (concat v "/package/" name))
+ (insert v))
+ (newline))
+ ('modules
+ (let ((firstp t))
+ (dolist (mod v)
+ (if firstp
+ (progn (setq firstp nil) (insert " "))
+ (insert "\n "))
+ (let* ((label (if (listp mod) (nth 0 mod) mod))
+ (mod-path (if (listp mod) (nth 1 mod) nil))
+ (doc-path+anchor (if (listp mod) (nth 2 mod) nil))
+ (private-p (string-match-p "/private/" label)))
+ (if mod-path
+ (insert-text-button label
+ :type 'racket-package-visit-path
+ 'path
(racket-file-name-back-to-front
+ mod-path)
+ 'face (if private-p
+ 'font-lock-comment-face
+ 'button))
+ (insert (propertize label
+ 'face (if private-p
+ 'font-lock-comment-face
+ 'default))))
+ (when doc-path+anchor
+ (let ((path (racket-file-name-back-to-front (car
doc-path+anchor)))
+ (anchor (cdr doc-path+anchor)))
+ (insert " ")
+ (insert-text-button "documentation"
+ :type
'racket-package-browse-file-url
+ 'face 'custom-button
+ 'path path
+ 'anchor anchor))))))
+ (newline))
+ ('tags
+ (insert " ")
+ (insert (string-join v " "))
+ (newline))
+ ('dir
+ (insert " ")
+ (insert-text-button v
+ :type 'racket-package-visit-path
+ 'path (racket-file-name-back-to-front v))
+ (newline))
+ ('source
+ (insert " ")
+ (pcase v
+ (`(,label url ,url)
+ (insert-text-button label
+ :type 'racket-package-browse-url
+ 'url url))
+ (`(,label path ,path)
+ (insert-text-button label
+ :type 'racket-package-visit-path
+ 'path (racket-file-name-back-to-front
path))))
+ (newline))
+ ('config-catalogs
+ (let ((firstp t))
+ (dolist (cat v)
+ (if firstp
+ (progn (setq firstp nil) (insert " "))
+ (insert "\n "))
+ (insert-text-button cat
+ :type 'racket-package-browse-url
+ 'url cat)))
+ (newline))
+ (_ (insert (format " %s\n" v))))))))))
+
+(define-button-type 'racket-package-browse-url
+ 'action #'racket-package-browse-url)
+
+(defun racket-package-browse-url (button)
+ (browse-url (button-get button 'url)))
+
+(define-button-type 'racket-package-visit-path
+ 'action #'racket-package-visit-path)
+
+(defun racket-package-visit-path (button)
+ (xref-push-marker-stack)
+ (find-file (button-get button 'path)))
+
+(define-button-type 'racket-package-browse-file-url
+ 'action #'racket-package-browse-file-url 'custom-face)
+
+(defun racket-package-browse-file-url (button)
+ (racket-browse-file-url (button-get button 'path)
+ (button-get button 'anchor)))
+
+(define-button-type 'racket-package-check-doc
+ 'action #'racket-package-check-doc
+ 'face 'custom-button)
+
+(defun racket-package-check-doc (&optional button)
+ (interactive)
+ (let ((name (button-get button 'racket-package-name)))
+ (racket--cmd/async
+ nil
+ `(pkg-doc-link ,name)
+ (lambda (result)
+ (pcase result
+ (`()
+ (message "No rendered documentation found for %s at %s"
+ name
+ racket--package-main-catalog))
+ (`((,_name ,url))
+ (browse-url url))
+ (choices
+ (racket-package-choose-docs name choices)))))))
+
+(defun racket-package-choose-docs (name choices)
+ (help-setup-xref (list #'racket-package-choose-docs name choices)
+ nil)
+ (with-help-window (help-buffer)
+ (with-current-buffer standard-output
+ (insert (format "Multiple documentation links available for package %s:"
+ name))
+ (newline)
+ (dolist (choice choices)
+ (pcase-let ((`(,label ,url) choice))
+ (insert
+ (propertize label
+ 'button '(t)
+ 'category 'default-button
+ 'action #'racket-package-browse-url
+ 'racket-package-url url))
+ (newline))))))
+
+(defun racket--package-insert-raco-pkg-op-button (verb name)
+ (insert-text-button (symbol-name verb)
+ :type 'racket-package-op
+ 'raco-pkg-verb verb
+ 'raco-pkg-name name))
+
+(define-button-type 'racket-package-op
+ 'action #'racket-raco-pkg-op
+ 'face 'custom-button)
+
+(defun racket-raco-pkg-op (&optional button)
+ (interactive)
+ (unless button (error "no raco pkg button here"))
+ (let ((verb (button-get button 'raco-pkg-verb))
+ (name (button-get button 'raco-pkg-name))
+ (inhibit-read-only t))
+ (pop-to-buffer (racket--package-notify-buffer-name)
+ '(display-buffer-below-selected))
+ (racket--cmd/async nil `(pkg-op ,verb ,name))))
+
+(defun racket--package-notify-buffer-name ()
+ (format "*Racket Package Operations <%s>*" (racket-back-end-name)))
+
+(defun racket--package-on-notify (v)
+ (with-current-buffer (get-buffer-create (racket--package-notify-buffer-name))
+ (unless (eq major-mode 'special-mode)
+ (special-mode))
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (pcase v
+ ('done
+ (insert (propertize "<done>\n\n"
+ 'face 'compilation-mode-line-exit))
+ (quit-window)
+ ;; Fully refresh *Racket Packages* list because "--auto" commands
+ ;; can install/remove/update multiple, dependent packages.
+ (with-current-buffer (racket--package-buffer-name)
+ (tabulated-list-revert)
+ (let ((win (get-buffer-window (current-buffer))))
+ (when win
+ (set-window-point win (point)))))
+ ;; Also refresh the status for this package in the *Help*
+ ;; buffer.
+ (with-current-buffer (help-buffer)
+ (revert-buffer)))
+ (`(error ,message)
+ (insert (propertize message
+ 'face 'compilation-error)))
+ (str
+ (insert (propertize str
+ 'face 'compilation-info))))
+ (goto-char (point-max)))))
+
+(provide 'racket-package)
+
+;; racket-package.el ends here
diff --git a/racket-xp-complete.el b/racket-xp-complete.el
index e5324e8deb..d57a9a0fe9 100644
--- a/racket-xp-complete.el
+++ b/racket-xp-complete.el
@@ -84,7 +84,8 @@ that are require transformers."
table)))
(list beg
end
- (racket--completion-table table 'file)
+ (racket--completion-table table
+ '((category . file)))
:exclusive 'no))))))))
(defun racket--xp-make-company-location-proc ()
diff --git a/racket/command-server.rkt b/racket/command-server.rkt
index 76e9a22291..3b004e71aa 100644
--- a/racket/command-server.rkt
+++ b/racket/command-server.rkt
@@ -12,6 +12,7 @@
(only-in "instrument.rkt" get-uncovered get-profile)
"hash-lang-bridge.rkt"
"logger.rkt"
+ "package.rkt"
"repl.rkt"
"repl-output.rkt"
"repl-session.rkt"
@@ -88,7 +89,8 @@
repl-output-channel
logger-notify-channel
debug-notify-channel
- hash-lang-notify-channel))
+ hash-lang-notify-channel
+ package-notify-channel))
(flush-output)
(loop))))
@@ -146,6 +148,10 @@
[`(doc-index-names) (doc-index-names)]
[`(doc-index-lookup ,str) (doc-index-lookup str)]
[`(hash-lang . ,more) (apply hash-lang more)]
+ [`(pkg-list) (package-list)]
+ [`(pkg-details ,str) (package-details str)]
+ [`(pkg-op ,verb ,name) (package-op verb name)]
+ [`(pkg-doc-link ,name) (catalog-package-doc-link name)]
;; Commands that MIGHT need a REPL session for context (e.g. its
;; namespace), if their first "how" argument is 'namespace.
diff --git a/racket/package.rkt b/racket/package.rkt
new file mode 100644
index 0000000000..7df6b1af87
--- /dev/null
+++ b/racket/package.rkt
@@ -0,0 +1,325 @@
+#lang racket/base
+
+(require (only-in racket/format ~a ~v ~s)
+ (only-in racket/hash hash-union!)
+ racket/match
+ racket/path
+ (only-in racket/string string-join)
+ (except-in pkg/lib
+ pkg-desc)
+ (only-in pkg/db
+ pkg?
+ get-pkgs
+ pkg-name
+ pkg-catalog
+ pkg-checksum
+ pkg-source
+ pkg-author
+ pkg-desc
+ get-pkg-dependencies
+ get-pkg-tags
+ get-pkg-modules)
+ (only-in pkg
+ pkg-config-command
+ pkg-install-command
+ pkg-update-command
+ pkg-remove-command)
+ pkg/name
+ (only-in setup/getinfo get-info/full)
+ net/url
+ (only-in "scribble.rkt"
+ module-doc-path
+ refresh-module-doc-path-index!))
+
+(provide package-list
+ package-details
+ package-op
+ catalog-package-doc-link
+ package-notify-channel)
+
+(define (package-list)
+ (define installed (installed-packages))
+ (define catalog (for/hash ([p (in-list (get-pkgs))])
+ (values (pkg-name p) p)))
+ (append
+ ;; All packages from the catalogs:
+ (for/list ([(name p) (in-hash catalog)])
+ (define ip (hash-ref installed name #f))
+ (define pi (and ip (installed-package-pkg-info ip)))
+ (define status (cond
+ [(not ip) "available"]
+ [(pkg-info-auto? pi) "dependency"]
+ [else "manual"]))
+ (list name
+ status
+ (cleanse-pkg-desc p)))
+ ;; Installed packages not from the catalogs, i.e. that we didn't
+ ;; already handle above:
+ (for/list ([name (in-hash-keys installed)]
+ #:when (not (hash-has-key? catalog name)))
+ (list name
+ "manual"
+ ""))))
+
+(define (package-details name)
+ (define props (make-hasheq))
+ (define (merge! . kvs)
+ (hash-union! props (apply hash kvs) #:combine (λ (_a b) b)))
+ ;; Start with props assuming neither catalog nor installed.
+ (merge! 'name name
+ 'status "unknown -- neither installed nor available from a catalog"
+ 'config-name (current-pkg-scope-version)
+ 'config-catalogs (or (current-pkg-catalogs)
+ (pkg-config-catalogs))
+ 'default-scope (~a (default-pkg-scope)))
+ ;; When pkg available from catalog, override with those details.
+ (match (get-pkgs #:name name)
+ [(cons (? pkg? p) _) ;if multiple, take just first
+ (merge! 'status "available"
+ 'source (catalog-package-source p)
+ 'checksum (pkg-checksum p)
+ 'author (pkg-author p)
+ 'tags (get-pkg-tags name (pkg-catalog p))
+ 'catalog (pkg-catalog p)
+ 'deps (for/list ([d (in-list (get-pkg-dependencies name
(pkg-catalog p) (pkg-checksum p)))])
+ (match-define (cons name qualifiers) d)
+ (cons name (string-join (map ~a qualifiers) " ")))
+ 'modules (sort
+ (for/list ([p (in-list (get-pkg-modules name
(pkg-catalog p) (pkg-checksum p)))])
+ (match p
+ [`(lib ,path) path]
+ [other (format "~v" other)]))
+ string<?)
+ 'description (cleanse-pkg-desc p))]
+ [(list) (void)])
+ ;; When pkg installed, override with those details.
+ (match (hash-ref (installed-packages) name #f)
+ [(? installed-package? ip)
+ (define pi (installed-package-pkg-info ip))
+ (define single? (sc-pkg-info? pi))
+ (define dir (simple-form-path (pkg-directory name)))
+ (merge! 'source (installed-package-source ip)
+ 'status (if (pkg-info-auto? pi) "dependency" "manual")
+ 'checksum (pkg-info-checksum pi)
+ 'scope (installed-package-scope ip)
+ 'dir (path->string dir)
+ 'modules (installed-package-modules dir single?))]
+ [#f (void)])
+ ;; Convert hash-table to association list. Omit values that are #f,
+ ;; null, or blank strings.
+ (for/list ([(k v) (in-hash props)]
+ #:when (match v
+ [(or #f (list) (regexp "^[ ]+$")) #f]
+ [_ #t]))
+ (cons k v)))
+
+(struct installed-package
+ (scope ;(or/c 'installation 'user)
+ pkg-info) ;pkg-info? including structs derived from pkg-info
+ #:transparent)
+(define (installed-packages)
+ (define ht (make-hash))
+ (for ([scope (in-list (list 'installation 'user))])
+ (for ([(name pi) (in-hash (installed-pkg-table #:scope scope))])
+ (hash-set! ht name (installed-package scope pi))))
+ ht)
+
+(define (cleanse-pkg-desc p)
+ (regexp-replace* "[\r\n]" (pkg-desc p) " "))
+
+;; The "source" from a package /catalog/ seems to be always a simple
+;; string, whereas for /installed packages/ the pkg-info-orig-pkg
+;; field is an expression as documented at
+;; <https://docs.racket-lang.org/pkg/path.html>.
+;;
+;; For the front end we want to return:
+;;
+;; 1. A label to display, such as ~s of the original or cleansed
+;; value.
+;;
+;; 2. A URL, or, a local filesystem path.
+;;
+;; - URL: simplify to an http(s) likely to work in a web browser to
+;; visit the web page for the user/repo.
+;;
+;; - Path, do package-source->path, complete relative to the
+;; scope's pkgs dir, and simplify.
+;;
+;; 3. A flag as to which kind 2 is, so the front end knows when it
+;; should do racket-mode-file-name-back-to-front.
+
+(define (installed-package-source ip)
+ (define source (pkg-info-orig-pkg (installed-package-pkg-info ip)))
+ (define scope (installed-package-scope ip))
+ (match source
+ ;; pkg-info-orig-pkg values for URLs
+ [(or (list (or 'catalog 'clone) _ url)
+ (list (or 'catalog 'git 'url) url))
+ (list (~s source)
+ 'url
+ (simplify-url url))]
+ ;; pkg-info-orig-pkg values for local paths
+ [(list (and type (or 'file 'dir 'link 'static-link)) raw-path)
+ (let ([path (path->string
+ (simplify-path
+ (path->complete-path (package-source->path raw-path type)
+ (get-pkgs-dir scope
+
(current-pkg-scope-version)))))])
+ (list (~s (list type path))
+ 'path
+ path))]))
+
+;; Note: Although my instinct was also to ignore "private" and
+;; "scribblings", pkg.r-l.org includes them, so I am, too. The front
+;; end UX could show them dimmed.
+(define ignore-dirs
+ (list (build-path ".git")
+ (build-path ".github")
+ (build-path "compiled")))
+
+(define (get-info pkg-dir key get-default)
+ (with-handlers ([exn:fail? (λ _ (get-default))])
+ (match (get-info/full pkg-dir #:bootstrap? #t)
+ [(? procedure? get) (get key get-default)]
+ [#f (get-default)])))
+
+(define (installed-package-modules pkg-dir single-collection-package?)
+ (define (parent-dir) (car (reverse (explode-path pkg-dir))))
+ (define prepend-collection-name
+ (and single-collection-package?
+ (match (get-info pkg-dir 'collection parent-dir)
+ ['use-pkg-name (parent-dir)]
+ [(? path-string? name) name]
+ ['multi #f]))) ;defensive
+ (define (use-dir? p)
+ (not (member (file-name-from-path p) ignore-dirs)))
+ (for*/list ([abs (in-directory pkg-dir use-dir?)]
+ #:when (member (path-get-extension abs)
+ '(#".rkt" #".ss" #".scrbl"))
+ [rel (in-value (find-relative-path pkg-dir abs))]
+ #:when (and rel
+ (not (equal? (file-name-from-path rel)
+ (build-path "info.rkt"))))
+ [rel (in-value (if prepend-collection-name
+ (build-path prepend-collection-name rel)
+ rel))])
+ (define-values (mod lang?)
+ (match (map path->string (explode-path rel))
+ [(list dirs ..1 (or "main.rkt" "main.ss"))
+ (values (apply build-path dirs) #f)]
+ [(list dirs ..1 "lang" "reader.rkt")
+ (values (apply build-path dirs) #t)]
+ [_
+ (values (path-replace-suffix rel #"") #f)]))
+ (define doc-path (module-doc-path (path->string mod) lang?))
+ (list rel abs doc-path)))
+
+(define git-protos-px #px"^(?:github|git|git\\+http|git\\+https)://")
+
+(define (simplify-url s)
+ (match s
+ ;; git flavors: Use https and simplify the path+query to just
+ ;; user and repo path elements.
+ [(pregexp git-protos-px)
+ (define u (string->url s))
+ (match-define (list* user repo _) (url-path u))
+ (url->string (struct-copy url u
+ [scheme "https"]
+ [path (list user repo)]
+ [query null]))]
+ [s s]))
+
+(define (simple-path-string ps)
+ (let ([ps (simplify-path
+ (path->complete-path ps
+ (get-pkgs-dir (current-pkg-scope)
+
(current-pkg-scope-version))))])
+ (if (string? ps)
+ ps
+ (path->string ps))))
+
+(define (catalog-package-source p)
+ (define source (pkg-source p))
+ (cons
+ (~a source)
+ (match source
+ ;; package catalog strings for URLs
+ [(and s (pregexp git-protos-px))
+ (list 'url (simplify-url s))]
+ [(and s (pregexp "^https?://"))
+ (list 'url s)]
+ ;; package catalog strings for local paths
+ [(pregexp "^(file://.+)[?]type=(.+)$" (list _ path type))
+ (list 'path (simple-path-string
+ (package-source->path path (string->symbol type))))]
+ [(and s (pregexp "^/[^/]"))
+ (list 'path (simple-path-string s))]
+ ;; Unknown
+ [_
+ (list 'unknown "")])))
+
+(define (catalog-package-doc-link name)
+ (with-handlers ([exn:fail? (λ _ null)])
+ (match (call/input-url (string->url
+ (format "https://pkgs.racket-lang.org/pkg/~a";
+ name))
+ get-pure-port
+ read)
+ [(hash-table ('build
+ (hash-table
+ ('docs docs))))
+ (for/list ([doc (in-list docs)])
+ (match-define (list _ name path) doc)
+ (list name
+ (string-append "https://pkg-build.racket-lang.org/"; path)))]
+ [_ #f])))
+
+;;; package operations
+
+(define package-notify-channel (make-channel))
+
+(define sema (make-semaphore 1))
+
+(define (package-op verb name)
+ (call-with-semaphore sema
+ (λ () (raw-package-op verb name))))
+
+(define (raw-package-op verb name)
+ (define act! (case verb
+ ['install (λ () (pkg-install-command #:auto #t name))]
+ ['update (λ () (pkg-update-command name))]
+ ['remove (λ () (pkg-remove-command #:auto #t name))]
+ [else (error 'package-op "unknown verb")]))
+ (define (put v)
+ (channel-put package-notify-channel
+ (cons 'pkg-op-notify v)))
+ (define-values (in out) (make-pipe))
+ (parameterize ([current-output-port out]
+ [current-error-port out])
+ (define (pump)
+ (define bstr (make-bytes 2048))
+ (match (read-bytes-avail! bstr in)
+ [(? exact-nonnegative-integer? n)
+ (put (bytes->string/utf-8 (subbytes bstr 0 n)))
+ (pump)]
+ [(? eof-object?)
+ (put 'done)]))
+ (thread pump)
+ (with-handlers ([exn:fail? (λ (exn)
+ (list 'error (exn-message exn)))])
+ (act!))
+ (flush-output out)
+ (close-output-port out)
+ (refresh-module-doc-path-index!)))
+
+(module+ example
+ (define (pump)
+ (match (channel-get package-notify-channel)
+ [(cons 'pkg-op-notify (? string? s)) (display s)]
+ [(cons 'pkg-op-notify 'done) (displayln "<Done>.")]
+ [(list 'pkg-op-notify 'error (? string? s)) (displayln s)])
+ (pump))
+ (thread pump)
+ (package-op 'install "ansi-color")
+ (package-op 'remove "ansi-color"))
+
diff --git a/racket/scribble.rkt b/racket/scribble.rkt
index d3bf46fba1..e52cb4751a 100644
--- a/racket/scribble.rkt
+++ b/racket/scribble.rkt
@@ -24,7 +24,9 @@
identifier->bluebox
doc-index-names
doc-index-lookup
- libs-exporting-documented)
+ libs-exporting-documented
+ module-doc-path
+ refresh-module-doc-path-index!)
(module+ test
(require rackunit))
@@ -62,7 +64,7 @@
(define racket-version->6.12? (version<? "6.12" (version)))
-(define bluebox-cache (delay (make-blueboxes-cache #t)))
+(define bluebox-cache (delay/thread (make-blueboxes-cache #t)))
(define/contract (identifier->bluebox stx)
(-> identifier? (or/c #f string?))
@@ -146,7 +148,6 @@
(define libs (exported-index-desc-from-libs desc))
(values kind libs)]
[else
- (println (reverse (explode-path path)))
(values 'documentation
(list
(match (reverse (explode-path path))
@@ -198,3 +199,31 @@
[(and (pregexp "^typed/racket/") v)
(string-append "1_" v)]
[v v])))))
+
+;; This is for package-details
+
+(define (build-module-doc-path-index)
+ (delay/thread
+ (define xref (force xref-promise))
+ (for*/hash ([entry (in-list (xref-index xref))]
+ [desc (in-value (entry-desc entry))]
+ [module? (in-value (module-path-index-desc? desc))]
+ [lang? (in-value (language-index-desc? desc))]
+ #:when (or module? lang?))
+ (define k (cons (car (entry-words entry))
+ lang?))
+ (define v (let-values ([(p a) (xref-tag->path+anchor xref (entry-tag
entry))])
+ (let ([p (path->string p)]
+ [a a])
+ (cons p a))))
+ (values k v))))
+
+(define module-doc-path-index (build-module-doc-path-index))
+
+(define (refresh-module-doc-path-index!)
+ (set! module-doc-path-index (build-module-doc-path-index)))
+
+(define (module-doc-path mod-path-str lang?)
+ (hash-ref (force module-doc-path-index)
+ (cons mod-path-str lang?)
+ #f))