Skip to content

Commit

Permalink
Many changes
Browse files Browse the repository at this point in the history 
I think this is much closer to feature complete now:

Add buttons for install/update/remove to details buffer.

Linkify deps and sources.

Don't keep refreshing catalog data.

Various other changes.
  • Loading branch information
@greghendershott
greghendershott committed Jun 14, 2024
1 parent 7a084bc commit 79f2f9b
Showing 1 changed file with 257 additions and 66 deletions.
323 changes: 257 additions & 66 deletions racket-package.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@

(require 'cl-macs)
(require 'seq)
(require 'url-parse)
(require 'racket-custom)

(defun racket--package-raco-pkg (command k)
Expand All @@ -22,11 +23,10 @@
(funcall k)))

(defvar racket--package-installed nil)

(defun racket--package-installed ()
(setq racket--package-installed nil)
(racket--package-raco-pkg "show --all --installation --long --dir"
(racket--package-installed-parse 'inst))
(racket--package-installed-parse 'installation))
(racket--package-raco-pkg "show --all --user --long --dir"
(racket--package-installed-parse 'user)))

Expand Down Expand Up @@ -69,7 +69,6 @@
(forward-line 1))))))

(defvar racket--package-catalog nil)

(defun racket--package-catalog ()
(setq racket--package-catalog nil)
(racket--package-raco-pkg
Expand Down Expand Up @@ -104,99 +103,291 @@
racket--package-catalog)))
racket--package-catalog)))

(defun racket-package-config ()
nil)

(defvar racket-packages-mode-map
(let ((m (make-sparse-keymap)))
(set-keymap-parent m nil)
(mapc (lambda (x)
(define-key m (kbd (car x)) (cadr x)))
'(("q" quit-window)
("RET" racket-package-details)))
m)
"Keymap for `racket-packages-mode'.")

(define-derived-mode racket-packages-mode tabulated-list-mode
"RacketPackages"
"Major mode for Racket package management.
\\{racket-package-mode-map}
"
(setq show-trailing-whitespace nil)
(setq tabulated-list-sort-key '("Name" . nil))
(setq tabulated-list-padding 2)
(setq tabulated-list-format
`[("Name" 15 t)
("Status" 10 t)
("Scope" 6 t)
("Checksum" 8 nil)
("Source" 15 t)
("Description" 15 t)]))

(defvar racket--package-installed+catalog (make-hash-table :test 'equal))
(defun racket--package-installed+catalog ()
;; Always refresh
(racket--package-installed)
(racket--package-catalog)
;; Never refresh
(unless racket--package-catalog
(racket--package-catalog))
(clrhash racket--package-installed+catalog)
(append
;; Eveything from catalog, possibly also installed
(seq-map (pcase-lambda (`(,name ,description ,checksum ,_deps ,_author ,source ,_tags))
(pcase-let ((`(,scope ,status ,status-face ,checksum ,source)
(pcase (assoc name racket--package-installed)
(`(,_name ,scope ,status ,checksum ,source ,_dir)
(list (symbol-name scope) (symbol-name status) 'package-status-installed checksum source))
(_
(list "" "available" 'package-status-available checksum source)))))
(list (cons name checksum)
(seq-map (pcase-lambda (`(,name ,description ,checksum ,deps ,author ,source ,tags))
(pcase-let* ((`(,scope ,status ,status-face ,checksum ,source ,dir)
(pcase (assoc name racket--package-installed)
(`(,_name ,scope ,status ,checksum ,source ,dir)
(list (symbol-name scope) (symbol-name status) 'package-status-installed checksum source dir))
(_
(list nil "available" 'package-status-available checksum source nil))))
(details (list :name name
:description description
:checksum checksum
:deps deps
:author author
:source source
:tags tags
:scope scope
:status status
:dir dir)))
(puthash name details racket--package-installed+catalog)
(list name
(vector (propertize name
'font-lock-face 'bold)
'face 'package-name
'font-lock-face 'package-name
'button '(t)
'category 'default-button
'follow-link t
'action #'describe-racket-package
'racket-package-details details)
(propertize status
'font-lock-face status-face)
(propertize scope
(propertize (or scope "")
'font-lock-face status-face)
(propertize checksum
'font-lock-face status-face)
source
description))))
racket--package-catalog)
;; Any additional installed, not handled above because not also from catalog.
;; Any additional installed, such as links, not handled above
;; because not also from catalog.
(seq-filter
#'identity
(seq-map (pcase-lambda (`(,name ,scope ,status ,checksum ,source ,_dir))
(seq-map (pcase-lambda (`(,name ,scope ,status ,checksum ,source ,dir))
(unless (assoc name racket--package-catalog)
(list (cons name checksum)
(vector (propertize name
'font-lock-face 'bold)
(propertize (symbol-name status)
'font-lock-face 'package-status-installed
'font-lock-face 'package-status-installed)
(propertize (symbol-name scope)
'font-lock-face 'package-status-installed)
(propertize checksum)
source
""))))
(let* ((status (symbol-name status))
(scope (symbol-name scope))
(details (list :name name
:scope scope
:status status
:checksum checksum
:source source
:dir dir)))
(puthash name details racket--package-installed+catalog)
(list name
(vector (propertize name
'face 'package-name
'font-lock-face 'package-name
'button '(t)
'category 'default-button
'follow-link t
'action #'describe-racket-package
'racket-package-details details)
(propertize status
'font-lock-face 'package-status-installed)
(propertize scope
'font-lock-face 'package-status-installed)
(propertize checksum)
source
"")))))
racket--package-installed))))

(defun racket-packages ()
(defun list-racket-packages ()
"Use raco pkg commands to populate a `racket-packages-mode' buffer."
(interactive)
(with-current-buffer (get-buffer-create "*Racket Packages*")
(unless (eq major-mode 'racket-packages-mode)
(racket-packages-mode))
(with-silent-modifications
(erase-buffer)
(setq tabulated-list-entries
(racket--package-installed+catalog))
(tabulated-list-init-header)
(tabulated-list-print))
(pop-to-buffer (current-buffer))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun racket-package-menu-describe ()
"Describe the package at point in a `racket-packages-mode' buffer."
(interactive)
(describe-racket-package (tabulated-list-get-id)))

(defun describe-racket-package (&optional name-or-button)
"Describe details of a Racket package."
(interactive "sRacket package name: ")
(let ((details (if name-or-button
(if (stringp name-or-button)
(gethash name-or-button
racket--package-installed+catalog)
(button-get name-or-button 'racket-package-details))
(gethash (tabulated-list-get-id)
racket--package-installed+catalog))))
(unless details (user-error "no package"))
(help-setup-xref (list #'describe-racket-package (plist-get details :name))
(called-interactively-p 'interactive))
(with-help-window (help-buffer)
(with-current-buffer standard-output
(racket--package-insert-details details)))))

(defun racket--package-insert-details (details)
(let ((name (plist-get details :name))
(status (plist-get details :status)))
(insert (propertize name
'font-lock-face 'bold))
(pcase status
("available"
(insert " is available to ")
(insert (propertize (format "raco pkg install --auto %s" name)
'button '(t)
'category 'default-button
'action #'racket--raco-pkg-mutate)))
("manual"
(insert " was manually installed\n\n")
(insert (propertize (format "raco pkg update --auto %s" name)
'button '(t)
'category 'default-button
'action #'racket--raco-pkg-mutate))
(insert " or ")
(insert (propertize (format "raco pkg remove --auto %s" name)
'button '(t)
'category 'default-button
'action #'racket--raco-pkg-mutate)))
("dependency"
(insert " was automatically installed as a dependency")))
(newline)
(newline)
(let ((lks `((" Directory" :dir)
(" Scope" :scope)
(" Source" :source)
(" Author" :author)
(" Tags" :tags)
("Dependencies" :deps)
(" Description" :description))))
(dolist (lk lks)
(pcase-let* ((`(,l ,k) lk)
(v (plist-get details k)))
(when v
(insert (propertize (concat l ":")
'font-lock-face 'package-help-section-name))
(pcase k
(:deps
(let ((firstp t))
(dolist (name v)
(if firstp
(progn (setq firstp nil) (insert " "))
(insert "\n "))
(if-let (details (gethash (car (split-string name))
racket--package-installed+catalog))
(insert (propertize name
'button '(t)
'category 'default-button
'follow-link t
'action #'describe-racket-package
'racket-package-details details))
(insert name))))
(newline))
(:source
(insert " ")
(insert (racket--package-linkify-source v))
(newline))
(_ (insert (format " %s\n" v))))))))))

(defun racket--raco-pkg-mutate (&optional button)
(interactive)
(unless button (error "no raco pkg button here"))
(let ((cmd (button-label button))
(inhibit-read-only t)
(_ (goto-char (point-max)))
(end-details (point)))
(newline)
(insert (propertize cmd 'font-lock-face 'bold))
(newline)
(call-process-shell-command cmd nil t t)
(newline)
(insert "Done.")
;; Fully refresh *Racket Packages* because "--auto" commands can
;; install/remove/update multiple, dependency packages.
(let ((id nil))
(with-current-buffer "*Racket Packages*"
(setq id (tabulated-list-get-id))
(tabulated-list-revert)
(when-let ((win (get-buffer-window (current-buffer))))
(set-window-point win (point))))
;; Also refresh the status for this package, at the top of this
;; detail buffer.
(delete-region (point-min) end-details)
(goto-char (point-min))
(when-let (details (gethash id racket--package-installed+catalog))
(racket--package-insert-details details))
(goto-char (point-min)))))

(define-derived-mode racket-package-details-mode special-mode
"RacketPackageDetails"
"Major mode for Racket packege details.")
(defun racket--package-linkify-source (str)
;; See "Package Sources" in docs esp re git and github source
;; schemes. The idea here is to get a URL that is likely to work in
;; a web browser for the repo, without trying to be too clever about
;; things like revisions etc.
(save-match-data
(cl-labels ((parse
(str)
(cond
((string-match (rx bos "("
"catalog "
"\"" (+? (not "\"")) "\""
" "
"\"" (group (+? (not "\""))) "\""
")" eos)
str)
(parse (match-string 1 str)))
((string-match (rx bos "("
(or "link" "static-link")
" "
"\"" (group (+? (not "\""))) "\""
")" eos)
str)
(parse (match-string 1 str)))
((string-match (rx bos "file://" (group (+? any)) (? "?type=" (+? any)) eos)
str)
(concat "file://" (match-string 1 str)))
;; git flavors: Use https and simplify the
;; path+query to just user and repo elements.
((string-match-p (rx bos (or "github://" "git://" "git+http://" "git+https://")) str)
(pcase-let* ((u (url-generic-parse-url str))
(`(,path . ,_query) (url-path-and-query u))
(`(,_ ,user ,repo . ,_) (split-string path "/"))
(path (concat "/" user "/" repo)))
(setf (url-type u) "https")
(setf (url-filename u) path)
(url-recreate-url u)))
;; Local file path; make file: url
((string-match (rx bos "/" (not "/"))
str)
(concat "file://" str))
(t str))))
(let ((url (parse str)))
(propertize str
'button '(t)
'category 'default-button
'action #'racket-browse-package-url
'racket-package-url url)))))
;; (racket--package-linkify-source "(static-link \"/path/to/file\")")
;; (racket--package-linkify-source "(catalog \"2d\" \"github://github.com/racket/2d?path=2d\")")

(defun racket-browse-package-url (button)
(browse-url (button-get button 'racket-package-url)))

(defvar racket-packages-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-menu-describe)))
m)
"Keymap for `racket-packages-mode'.")

(defun racket-package-details ()
(interactive))
(define-derived-mode racket-packages-mode tabulated-list-mode
"RacketPackages"
"Major mode for Racket package management.
\\{racket-package-mode-map}
"
(setq show-trailing-whitespace nil)
(setq tabulated-list-sort-key '("Name" . nil))
(setq tabulated-list-padding 2)
(setq tabulated-list-format
`[("Name" 20 t)
("Status" 10 t)
("Scope" 6 t)
("Checksum" 8 nil)
("Source" 15 t)
("Description" 15 t)])
(setq tabulated-list-entries #'racket--package-installed+catalog))

(provide 'racket-package)

Expand Down

0 comments on commit 79f2f9b

Please sign in to comment.