pkg/gui: first cut at a GUI package manager

For now, run it with `racket -l pkg/gui/main'. The expectation
is that DrRacket will start using this GUI.

collects/meta/dist-specs.rkt

@@ -556,7 +556,11 @@ plt-extras :+= (package: "slatex")
 
 ;; -------------------- planet
 mz-extras :+= (package: "planet")
-mz-extras :+= (package: "pkg")
+
+;; -------------------- pkg
+mz-extras :+= (- (package: "pkg")
+                 (collects: "pkg/gui/"))
+dr-extras :+= (collects: "pkg/gui/")
 
 ;; -------------------- mrlib
 mr-extras :+= (+ (- (package: "mrlib/") 

collects/meta/props

@@ -859,6 +859,8 @@ path/s is either such a string or a list of them.
 "collects/parser-tools/private-lex/error-tests.rkt" drdr:command-line #f
 "collects/picturing-programs" responsible (sbloch)
 "collects/pkg" responsible (jay)
+"collects/pkg/gui" responsible (mflatt)
+"collects/pkg/gui/main.rkt" drdr:command-line (mzc *)
 "collects/plai" responsible (jay)
 "collects/planet" responsible (robby)
 "collects/plot" responsible (ntoronto)

collects/pkg/gui/by-installed.rkt

@@ -0,0 +1,168 @@
+#lang racket/base
+(require racket/class
+         racket/gui/base
+         racket/format
+         pkg/lib
+         (prefix-in pkg: pkg)
+         string-constants
+         "common.rkt")
+
+(provide by-installed-panel%)
+
+(struct ipkg (name scope auto? checksum source))
+
+(define (scope<? a b)
+  (case a
+    [(installation) #t]
+    [(user) (eq? b 'shared)]
+    [else #f]))
+
+(define (ipkg<? a b)
+  (if (string=? (ipkg-name a) (ipkg-name b))
+      (scope<? (ipkg-scope a) (ipkg-scope b))
+      (string<? (ipkg-name a) (ipkg-name b))))
+
+(define by-installed-panel%
+  (class vertical-panel%
+    (init-field [in-terminal in-terminal])
+
+    (super-new)
+
+    (inherit get-top-level-window)
+
+    (define pkg-list
+      (new list-box%
+           [parent this]
+           [label #f]
+           [choices null]
+           [columns (list "Auto?/Scope" "Name" "Checksum" "Source")]
+           [style '(multiple column-headers clickable-headers)]
+           [callback (lambda (lb e)
+                       (when (e . is-a? . column-control-event%)
+                         (define sb (send e get-column))
+                         (if (= sb sort-by)
+                             (set! flip? (not flip?))
+                             (begin
+                               (set! sort-by sb)
+                               (set! flip? #f)))
+                         (sort-list!))
+                       (adjust-buttons!))]))
+
+    (define sort-by 0)
+    (define flip? #f)
+    (define installed '())
+    (define sorted-installed '#())
+
+    (define/override (on-superwindow-show on?)
+      (when on?
+        (reset-installed-list!)))
+
+    (define/private (reset-installed-list!)
+      (set! installed
+            (for*/list ([scope (in-list '(installation user shared))]
+                        [(k v) (in-hash (installed-pkg-table #:scope scope))])
+              (ipkg k scope (pkg-info-auto? v) (pkg-info-checksum v) (pkg-info-orig-pkg v))))
+      (sort-list!))
+
+    (define/private (selected-ipkgs)
+      (for/list ([i (in-list (send pkg-list get-selections))])
+        (vector-ref sorted-installed i)))
+    
+    (define button-line
+      (new horizontal-panel%
+           [parent this]
+           [alignment '(center center)]
+           [stretchable-height #f]))
+
+    (define remove-button
+      (new button%
+           [label sc-install-pkg-remove]
+           [parent button-line]
+           [callback (lambda (b e)
+                       (define ipkgs (selected-ipkgs))
+                       (define names (map ipkg-name ipkgs))
+                       (when (really-remove? names #:parent (get-top-level-window))
+                         (define scope (ipkg-scope (car ipkgs)))
+                         (in-terminal
+                          (string-constant install-pkg-abort-remove)
+                          (lambda ()
+                            (apply
+                             pkg:remove
+                             #:scope scope
+                             names)))
+                         (reset-installed-list!)))]))
+
+    (define update-button
+      (new button%
+           [label (string-constant install-pkg-update)]
+           [parent button-line]
+           [callback (lambda (b e)
+                       (define ipkgs (selected-ipkgs))
+                       (define names (map ipkg-name ipkgs))
+                       (define scope (ipkg-scope (car ipkgs)))
+                       (in-terminal
+                        (string-constant install-pkg-abort-update)
+                        (lambda ()
+                          (apply
+                           pkg:update
+                           #:scope scope
+                           names)))
+                       (reset-installed-list!))]))
+
+    (define/private (adjust-buttons!)
+      (define ipkgs (selected-ipkgs))
+      (define same-scope? (and (pair? ipkgs)
+                               ;; must be all in the same scope:
+                               (for/and ([i (cdr ipkgs)])
+                                 (eq? (ipkg-scope i) (ipkg-scope (car ipkgs))))))
+      (send remove-button enable same-scope?)
+      (send update-button enable (and same-scope?
+                                      (for/and ([i (in-list ipkgs)])
+                                        (not (eq? 'link (car (ipkg-source i))))))))
+
+    (define/private (sort-list!)
+      (define l (sort installed
+                      (lambda (a b)
+                        ((if flip? not values)
+                         (case sort-by
+                           [(0) (if (eq? (ipkg-scope a) (ipkg-scope b))
+                                    (if (eq? (ipkg-auto? a) (ipkg-auto? b))
+                                        (string<? (ipkg-name a) (ipkg-name b))
+                                        (not (ipkg-auto? a)))
+                                    (scope<? (ipkg-scope a) (ipkg-scope b)))]
+                           [(1) (ipkg<? a b)]
+                           [(2) (if (equal? (ipkg-checksum a) (ipkg-checksum b))
+                                    (ipkg<? a b)
+                                    (cond
+                                     [(not (ipkg-checksum a)) #f]
+                                     [(not (ipkg-checksum b)) #t]
+                                     [else (string<? (ipkg-checksum a) (ipkg-checksum b))]))]
+                           [(3) 
+                            (define sa (ipkg-source a))
+                            (define sb (ipkg-source b))
+                            (if (equal? sa sb)
+                                (ipkg<? a b)
+                                (if (eq? (car sa) (car sb))
+                                    (string<? (cadr sa) (cadr sb))
+                                    (case (car sa)
+                                      [(link) #t]
+                                      [(catalog) (eq? b 'url)]
+                                      [(url) #f])))])))))
+      (set! sorted-installed (list->vector l))
+      (send pkg-list set
+            (for/list ([i (in-list l)])
+              (~a (if (ipkg-auto? i) "*" "")
+                  (ipkg-scope i)))
+            (for/list ([i (in-list l)])
+              (format "~a" (ipkg-name i)))
+            (for/list ([i (in-list l)])
+              (or (ipkg-checksum i) ""))
+            (for/list ([i (in-list l)])
+              (define s (ipkg-source i))
+              (format "~a: ~a"
+                      (case (car s)
+                        [(catalog) "Catalog"]
+                        [(url) "URL"]
+                        [(link) "Link"])
+                      (cadr s))))
+      (adjust-buttons!))))

collects/pkg/gui/by-list.rkt

@@ -0,0 +1,497 @@
+#lang racket/base
+(require racket/class
+         racket/gui/base
+         racket/port
+         racket/set
+         racket/format
+         string-constants
+         net/url
+         pkg/lib
+         (prefix-in pkg: pkg)
+         (prefix-in db: pkg/db)
+         "common.rkt")
+
+(provide by-list-panel%)
+
+(define sc-pkg-update-package-list (string-constant install-pkg-update-package-list))
+(define sc-pkg-stop-update (string-constant install-pkg-stop-update))
+
+(define check-mark "✓")
+
+(define default-status
+  (~a check-mark ": installed"
+      "  "
+      "*: auto-installed"
+      "  "
+      "!: not default scope"
+      "  "
+      "=: installed as link"
+      "  "
+      "@: installed from URL"))
+
+(define by-list-panel%
+  (class vertical-panel%
+    (init-field [in-terminal in-terminal])
+
+    (super-new)
+
+    (inherit get-top-level-window)
+
+    (define tool-panel
+      (new horizontal-panel%
+           [parent this]
+           [alignment '(left center)]
+           [stretchable-height #f]))
+
+    (define keep-rx #rx"")
+    (define/private (list-pkg-keep? a)
+      (or (regexp-match? keep-rx (db:pkg-name a))
+          (regexp-match? keep-rx (db:pkg-author a))
+          (regexp-match? keep-rx (db:pkg-desc a))
+          (regexp-match? keep-rx (format-tags (pkg-tags a)))
+          (regexp-match? keep-rx (db:pkg-source a))
+          (regexp-match? keep-rx (db:pkg-catalog a))))
+
+    (define filter-text
+      (new text-field%
+           [label (~a (string-constant install-pkg-filter) ":")]
+           [parent tool-panel]
+           [font small-control-font]
+           [stretchable-width #t]
+           [callback (lambda (tf e)
+                       (define s (send tf get-value))
+                       (define terms (filter (lambda (s) (not (string=? s "")))
+                                             (regexp-split #rx"[, \t\r\n]" s)))
+                       (define rx
+                         (regexp (apply ~a
+                                        #:separator "|"
+                                        (for/list ([term terms])
+                                          (~a "(?i:" (regexp-quote term) ")")))))
+                       (unless (equal? rx keep-rx)
+                         (set! keep-rx rx)
+                         (sort-pkg-list!)))]))
+
+    (define filter-result
+      (new message%
+           [label "9999/9999 match"]
+           [parent tool-panel]
+           [font small-control-font]))
+    (send filter-result set-label "")
+  
+    (define updating? #f)
+
+    (define update-button
+      (new button%
+           [label sc-pkg-update-package-list]
+           [parent tool-panel]
+           [font small-control-font]
+           [callback
+            (lambda (b e)
+              (if updating?
+                  (interrupt-task!)
+                  (update-db-package-list)))]))
+
+    (define status-text
+      (new message%
+           [parent this]
+           [label default-status]
+           [font small-control-font]
+           [stretchable-width #t]))
+
+    (define sort-column -1)
+    (define list-pkg<? (lambda (a b) #f))
+
+    (define/private (sort-by! col)
+      (define sel (case col
+                    [(0 1) db:pkg-name]
+                    [(2) db:pkg-author]
+                    [(3) db:pkg-desc]
+                    [(4) (lambda (p) (format-tags (pkg-tags p)))]
+                    [(5) db:pkg-checksum]
+                    [(6) db:pkg-source]
+                    [(7) db:pkg-catalog]))
+      (define switch (if (= sort-column col)
+                         not
+                         values))
+      (set! sort-column (if (= sort-column col)
+                            -1
+                            col))
+      (set! list-pkg<?
+            (lambda (a b)
+              (switch
+               (cond
+                [(and (not (string=? (sel a) ""))
+                      (string=? (sel b) ""))
+                 #t]
+                [(and (string=? (sel a) "")
+                      (not (string=? (sel b) "")))
+                 #f]
+                [(string<? (sel a) (sel b)) #t]
+                [(string=? (sel a) (sel b))
+                 (cond
+                  [(string<? (db:pkg-name a) (db:pkg-name b)) #t]
+                  [(string=? (db:pkg-name a) (db:pkg-name b))
+                   (string<? (db:pkg-catalog a) (db:pkg-catalog))]
+                  [else #f])]
+                [else #f])))))
+    (sort-by! 7)
+
+    (define pkg-list
+      (new list-box%
+           [parent this]
+           [label #f]
+           [choices null]
+           [columns (list check-mark "Package" "Author" "Description" "Tags" "Checksum" "Source" "Catalog")]
+           [style '(multiple column-headers clickable-headers)]
+           [callback (lambda (lb e)
+                       (when (e . is-a? . column-control-event%)
+                         (sort-by! (send e get-column))
+                         (sort-pkg-list!))
+                       (adjust-buttons!))]))
+    
+    (send pkg-list set-column-width 0 30 2 1000)
+    (send pkg-list set-column-width 3 300 2 1000)
+
+    (define button-line
+      (new horizontal-panel%
+           [parent this]
+           [alignment '(center center)]
+           [stretchable-height #f]))
+
+    (define install-button
+      (new button%
+           [label (string-constant install-pkg-install)]
+           [parent button-line]
+           [style '(border)]
+           [callback (lambda (b e)
+                       (define pkgs (selected-pkgs))
+                       (define names (map db:pkg-name pkgs))
+                       (define first-inst
+                         (hash-ref installed (db:pkg-name (car pkgs)) #f))
+                       (define s (queue-scroll!))
+                       (in-terminal
+                        (if first-inst
+                            (string-constant install-pkg-abort-update)
+                            (string-constant install-pkg-abort-install))
+                        (lambda ()
+                          (apply
+                           (if first-inst pkg:update pkg:install)
+                           #:scope (and first-inst
+                                        (car first-inst))
+                           names)))
+                       (set-box! s #f)
+                       (refresh-installed-list!))]))
+    (define remove-button
+      (new button%
+           [label sc-install-pkg-remove]
+           [parent button-line]
+           [callback (lambda (b e)
+                       (define pkgs (selected-pkgs))
+                       (define names (map db:pkg-name pkgs))
+                       (when (really-remove? names #:parent (get-top-level-window))
+                         (define scope
+                           (car (hash-ref installed (db:pkg-name (car pkgs)) #f)))
+                         (define s (queue-scroll!))
+                         (in-terminal
+                          (string-constant install-pkg-abort-remove)
+                          (lambda ()
+                            (apply
+                             pkg:remove
+                             #:scope scope
+                             names)))
+                         (set-box! s #f)
+                         (refresh-installed-list!)))]))
+
+    ;; When a terminal panel appears, it may shrink the
+    ;; list box enough that the selected item is not visible,
+    ;; so re-sort to adjust scrolling:
+    (define (queue-scroll!)
+      (define b (box #t))
+      (queue-callback (lambda ()
+                        (when (unbox b)
+                          (sort-pkg-list!)))
+                      #f)
+      b)
+
+    (define/private (selected-pkgs)
+      (for/list ([i (in-list (send pkg-list get-selections))])
+        (send pkg-list get-data i)))
+
+    (define/private (adjust-buttons!)
+      (define sels (for/list ([p (selected-pkgs)])
+                     (hash-ref installed (db:pkg-name p) #f)))
+      (define all-installed? (and (pair? sels) 
+                                  (andmap values sels)
+                                  ;; must be all in the same scope:
+                                  (for/and ([p (cdr sels)])
+                                    (eq? (car p) (caar sels)))))
+      (define none-installed? (not (ormap values sels)))
+      (send install-button enable (and (pair? sels)
+                                       (or (and all-installed?
+                                                (not (for/or ([p (in-list sels)])
+                                                       (eq? 'link (car (pkg-info-orig-pkg (cdr p)))))))
+                                           none-installed?)))
+      (send install-button set-label (if all-installed?
+                                         (string-constant install-pkg-update)
+                                         (string-constant install-pkg-install)))
+      (send remove-button enable all-installed?))
+
+    (adjust-buttons!)
+
+    (define/private (check-catalogs)
+      (define user-catalogs (pkg-config-catalogs))
+      (define db-catalogs (db:get-catalogs))
+      (unless (equal? (list->set db-catalogs)
+                      (list->set user-catalogs))
+        (when (= 1 (message-box/custom "Package Catalogs"
+                                       (~a
+                                        (string-constant install-pkg-update-catalogs?)
+                                        "\n\n"
+                                        (string-constant install-pkg-currently-configured-are) ":\n"
+                                        (apply ~a
+                                               (for/list ([url user-catalogs])
+                                                 (~a "  " url "\n")))
+                                        "\n"
+                                        (string-constant install-pkg-database-recorded-are) ":\n"
+                                        (apply ~a
+                                               (for/list ([url db-catalogs])
+                                                 (~a "  " url "\n"))))
+                                       (string-constant install-pkg-update-catalogs)
+                                       (string-constant install-pkg-do-not-update-catalogs)
+                                       #f
+                                       this
+                                       '(caution default=1)))
+          (db:set-catalogs! user-catalogs)
+          (update-db-package-list))))
+
+    (define/private (check-init)
+      (unless (file-exists? (db:current-pkg-catalog-file))
+        (db:set-catalogs! (pkg-config-catalogs))
+        (update-db-package-list)))
+
+    (define task #f)
+    (define finalize void)
+    
+    (define/private (task! thunk given-finalize)
+      (define finalized? #f)
+      (set! finalize (lambda (ok?)
+                       (unless finalized?
+                         (set! finalized? #t)
+                         (given-finalize ok?))))
+      (set! task (thread 
+                  (lambda ()
+                    (with-handlers ([exn:break? void])
+                      (thunk)
+                      (let ([f finalize])
+                        (queue-callback/wait (lambda () (f #t)))))))))
+
+    (define/private (queue-callback/wait thunk)
+      (define s (make-semaphore))
+      (define ok? #t)
+      (queue-callback (lambda ()
+                        (when ok?
+                          (thunk)
+                          (semaphore-post s))))
+      (dynamic-wind
+          void
+          (lambda () (semaphore-wait s))
+          (lambda () (set! ok? #f))))
+
+    (define/private (interrupt-task!)
+      (when task
+        (break-thread task)
+        (sync task)
+        (finalize #f))
+      (set! task #f)
+      (send status-text set-label default-status))
+
+    (define/private (update-db-package-list)
+      (interrupt-task!)
+      (set! updating? #t)
+      (send update-button set-label sc-pkg-stop-update)
+      (send status-text set-label "Updating package list...")
+      (task!
+       (lambda ()
+         (define db-catalogs (db:get-catalogs))
+         (for ([catalog (in-list db-catalogs)])
+           (queue-callback/wait
+            (lambda ()
+              (send status-text set-label (format "Updating from ~a..." catalog))))
+           (define details
+             (parameterize ([current-pkg-catalogs (list (string->url catalog))])
+               (get-all-pkg-details-from-catalogs)))
+           (db:set-pkgs! catalog (for/list ([(name ht) (in-hash details)])
+                                   (db:pkg name
+                                           catalog
+                                           (hash-ref ht 'author "")
+                                           (hash-ref ht 'source "")
+                                           (hash-ref ht 'checksum "")
+                                           (hash-ref ht 'description ""))))
+           (for/list ([(name ht) (in-hash details)])
+             (db:set-pkg-tags! name catalog (hash-ref ht 'tags '())))))
+       (lambda (finished?)
+         (send status-text set-label default-status)
+         (set! updating? #f)
+         (send update-button set-label sc-pkg-update-package-list)
+         (refresh-pkg-list!))))
+
+    (define/private (background-pkg-details)
+      (task!
+       (lambda ()
+         (define catalog-ht (make-hash))
+         (for ([a-pkg (in-vector pkgs)]
+               [pos (in-naturals)])
+           (define name (db:pkg-name a-pkg))
+           (define catalog (db:pkg-catalog a-pkg))
+           (send status-text set-label 
+                 (~a "Getting details for " name " from " catalog "..."))
+           (define all-ht 
+             (or (hash-ref catalog-ht catalog #f)
+                 (let ([all-ht (parameterize ([current-pkg-catalogs (list (string->url catalog))])
+                                 (get-all-pkg-details-from-catalogs))])
+                   (hash-set! catalog-ht catalog all-ht)
+                   all-ht)))
+           (define ht (hash-ref all-ht name))
+           (define author (hash-ref ht 'author ""))
+           (define source (hash-ref ht 'source ""))
+           (define checksum (hash-ref ht 'checksum ""))
+           (define desc (hash-ref ht 'description ""))
+           (define tags (hash-ref ht 'tags '()))
+           (define new-pkg (db:pkg name catalog author source checksum desc))
+           (unless (and (equal? new-pkg a-pkg)
+                        (equal? tagss (pkg-tags a-pkg)))
+             (db:set-pkg! name catalog author source checksum desc)
+             (db:set-pkg-tags! name catalog tags)
+             (queue-callback/wait
+              (lambda ()
+                (vector-set! pkgs pos new-pkg)
+                (set! tagss (hash-set (hash-remove tagss a-pkg)
+                                      new-pkg
+                                      tags))
+                (define lpos (vector-ref posns pos))
+                (when lpos
+                  (send pkg-list set-string lpos (->label-string author) 2)
+                  (send pkg-list set-string lpos (->label-string desc) 3)
+                  (send pkg-list set-string lpos (->label-string (format-tags tags)) 4)
+                  (send pkg-list set-string lpos (->label-string checksum) 5)
+                  (send pkg-list set-string lpos (->label-string source) 6)))))))
+       (lambda (ok?)
+         (send status-text set-label default-status))))
+
+    (define/private (->label-string s)
+      (substring s 0 (min 200 (string-length s))))
+
+    (define pkgs '#())
+    (define tagss #(hash))
+    (define posns '#())
+    (define installed '#())
+    (define default-scope 'user)
+    
+    (define/private (refresh-pkg-list!)
+      (define pkg-list (db:get-pkgs))
+      (define tags-list (map (lambda (p)
+                               (db:get-pkg-tags (db:pkg-name p)
+                                                (db:pkg-catalog p)))
+                             pkg-list))
+      (set! pkgs (list->vector pkg-list))
+      (set! tagss (for/hash ([p (in-list pkg-list)]
+                             [t (in-list tags-list)])
+                    (values p t)))
+      (set! default-scope (default-pkg-scope))
+      (refresh-installed-list! #:always? #t))
+
+    (define/private (refresh-installed-list! #:always? [always? #f])
+      (define new-installed
+        (for*/hash ([scope (in-list '(installation user shared))]
+                    [(k v) (in-hash (installed-pkg-table #:scope scope))])
+          (values k (cons scope v))))
+      (when (or always?
+                (not (equal? installed new-installed)))
+        (set! installed new-installed)
+        (sort-pkg-list!)))
+
+    (define/private (pkg-tags p)
+      (hash-ref tagss p '()))
+    
+    (define/private (sort-pkg-list!)
+      (define sels (for/list ([i (in-list (send pkg-list get-selections))])
+                     (define p (send pkg-list get-data i))
+                     (cons (db:pkg-name p) (db:pkg-catalog p))))
+      (set! posns (make-vector (vector-length pkgs) #f))
+      (define list-pkg+poses
+        (sort
+         (filter
+          (lambda (p) (list-pkg-keep? (car p)))
+          (for/list ([p pkgs]
+                     [i (in-naturals)])
+            (cons p i)))
+         list-pkg<?
+         #:key car))
+      (for ([p (in-list list-pkg+poses)]
+            [j (in-naturals)])
+        (vector-set! posns (cdr p) j))
+      (define list-pkgs (map car list-pkg+poses))
+      (send filter-result set-label (format "~a/~a match" 
+                                            (length list-pkgs)
+                                            (vector-length pkgs)))
+      (send pkg-list set
+            (for/list ([p list-pkgs])
+              (define v (hash-ref installed (db:pkg-name p) #f))
+              (cond
+               [(not v) ""]
+               [else
+                (define info (cdr v))
+                (~a (cond 
+                     [(pkg-info-auto? info) "*"]
+                     [else check-mark])
+                    (cond
+                     [(eq? (car v) default-scope) ""]
+                     [else "!"])
+                    (case (car (pkg-info-orig-pkg info))
+                      [(catalog) ""]
+                      [(link) "="]
+                      [(url) "@"]))]))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-name p)))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-author p)))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-desc p)))
+            (for/list ([p list-pkgs]) (->label-string (format-tags (pkg-tags p))))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-checksum p)))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-source p)))
+            (for/list ([p list-pkgs]) (->label-string (db:pkg-catalog p))))
+      (let ([ht (for/hash ([p list-pkgs]
+                           [i (in-naturals)])
+                  (send pkg-list set-data i p)
+                  (values (cons (db:pkg-name p) (db:pkg-catalog p))
+                          i))])
+        (for/fold ([did? #f]) ([sel (in-list sels)])
+          (define i (hash-ref ht sel #f))
+          (when i
+            (if did?
+                (send pkg-list select i)
+                (begin
+                  (send pkg-list set-selection i)
+                  (let ([f (send pkg-list get-first-visible-item)]
+                        [n (send pkg-list number-of-visible-items)])
+                    (unless (<= f i (+ f n -1))
+                      (send pkg-list set-first-visible-item
+                            (if (i . < . f)
+                                i
+                                (max 0 (add1 (- i n))))))))))
+          (or did? i)))
+      (adjust-buttons!))
+
+    (define/private (format-tags tags)
+      (apply ~a #:separator ", " tags))
+
+    (define prepared? #f)
+
+    (define/override (on-superwindow-show on?)
+      (if on?
+          (cond
+           [prepared? (refresh-installed-list!)]
+           [else
+            (check-init)
+            (refresh-pkg-list!)
+            (check-catalogs)
+            (set! prepared? #t)])
+          (interrupt-task!)))))

collects/pkg/gui/by-source.rkt

@@ -0,0 +1,395 @@
+#lang racket/base
+
+(require racket/gui/base 
+         racket/class
+         racket/format
+         string-constants
+         pkg/name
+         pkg/lib
+         pkg
+         racket/list
+         framework
+         net/url)
+
+(provide by-source-panel%)
+
+(define sc-install-pkg-dialog-title (string-constant install-pkg-dialog-title))
+(define sc-install-pkg-source-label (string-constant install-pkg-source-label))
+(define sc-install-pkg-type-label (string-constant install-pkg-type-label))
+(define sc-install-pkg-infer (string-constant install-pkg-infer))
+(define sc-install-pkg-file (string-constant install-pkg-file))
+(define sc-install-pkg-dir (string-constant install-pkg-dir))
+(define sc-install-pkg-dir-url (string-constant install-pkg-dir-url))
+(define sc-install-pkg-file-url (string-constant install-pkg-file-url))
+(define sc-install-pkg-github (string-constant install-pkg-github))
+(define sc-install-pkg-name (string-constant install-pkg-name))
+(define sc-install-pkg-inferred-as (string-constant install-pkg-inferred-as))
+(define sc-install-pkg-force? (string-constant install-pkg-force?))
+(define sc-install-pkg-command-line (string-constant install-pkg-command-line))
+
+(define sc-install-pkg-action-label (string-constant install-pkg-action-label))
+(define sc-install-pkg-install (string-constant install-pkg-install))
+(define sc-install-pkg-update (string-constant install-pkg-update))
+(define sc-action-inferred-to-be-update (string-constant install-pkg-action-inferred-to-be-update))
+(define sc-action-inferred-to-be-install (string-constant install-pkg-action-inferred-to-be-install))
+
+(define sc-install-pkg-default (string-constant install-pkg-default))
+(define sc-install-pkg-scope-label (string-constant install-pkg-scope-label))
+(define sc-install-pkg-installation (string-constant install-pkg-installation))
+(define sc-install-pkg-user (string-constant install-pkg-user))
+(define sc-install-pkg-shared (string-constant install-pkg-shared))
+(define sc-install-pkg-set-as-default (string-constant install-pkg-set-as-default))
+(define sc-install-pkg-scope-is (string-constant install-pkg-scope-is))
+  
+(define sc-install-pkg-browse (string-constant browse...))
+
+(preferences:set-default 'drracket:gui-installer-pkg-source "" string?)
+
+(define by-source-panel%
+  (class vertical-panel%
+    (init-field [in-terminal in-terminal])
+
+    (super-new)
+    
+    (inherit get-top-level-window)
+
+    (define source-panel (new horizontal-panel% 
+                              [parent this] 
+                              [stretchable-height #f]))
+
+    (define tf (new text-field% 
+                    [parent source-panel] 
+                    [min-width 600]
+                    [label (~a sc-install-pkg-source-label ":")]
+                    [callback (λ (_1 _2) 
+                                 (preferences:set 'drracket:gui-installer-pkg-source (send tf get-value))
+                                 (adjust-all))]))
+    (send tf set-value (preferences:get 'drracket:gui-installer-pkg-source))
+
+    (define browse-button (new button%
+                               [parent source-panel]
+                               [label (string-constant browse...)]
+                               [font small-control-font]
+                               [callback (lambda (b e)
+                                           (define mode (send choice get-string-selection))
+                                           (define dir? (or (equal? mode sc-install-pkg-dir)
+                                                            (equal? mode sc-install-pkg-dir-url)))
+                                           (define f
+                                             (cond
+                                              [dir?
+                                               (get-directory (string-constant install-pkg-select-package-directory)
+                                                              (get-top-level-window))]
+                                              [else
+                                               (parameterize ([finder:default-filters
+                                                               '(("Package" "*.zip;*.plt;*.tgz;*.tar")
+                                                                 ("Any" "*.*"))])
+                                                 (finder:get-file #f (string-constant install-pkg-select-package-file)
+                                                                  #f "bad"
+                                                                  (get-top-level-window)))]))
+                                           (when f
+                                             (send tf set-value 
+                                                   (url->string (path->url (if dir?
+                                                                               (path->directory-path f) 
+                                                                               f))))
+                                             (adjust-all)))]))
+    
+    (define button-panel (new horizontal-panel% 
+                              [parent this] 
+                              [stretchable-height #f]))
+    (define details-parent (new vertical-panel% [parent this]))
+    (define details-panel (new group-box-panel% 
+                               [label (string-constant autosave-details)]
+                               [parent details-parent]
+                               [alignment '(left center)]
+                               [stretchable-height #f]))
+
+    (define ok-button
+      (new button%
+           [label sc-install-pkg-install]
+           [parent button-panel]
+           [style '(border)]
+           [callback (lambda (b e)
+                       (define res (compute-cmd-line))
+                       (in-terminal
+                        (case (car res)
+                          [(install) (string-constant install-pkg-abort-install)]
+                          [(update) (string-constant install-pkg-abort-update)])
+                        (lambda ()
+                          (define action (case (car res)
+                                           [(install) install]
+                                           [(update) update]))
+                          (apply action (cdr res))))
+                       (reset-installed-pkgs!))]))
+
+    (define/private (reset-installed-pkgs!)
+      (set! currently-installed-pkgs (installed-pkg-names))
+      (adjust-all))
+    
+    (new horizontal-panel% [parent button-panel])
+    (define details-shown? #f)
+    (define details-button (new button% 
+                                [label (string-constant show-details-button-label)]
+                                [parent button-panel]
+                                [callback
+                                 (λ (a b)
+                                    (set! details-shown? (not details-shown?))
+                                    (adjust-all))]))
+
+    (send details-parent change-children (λ (l) '()))
+    (define choice (new choice%
+                        [label (~a sc-install-pkg-type-label ":")]
+                        [parent details-panel]
+                        [stretchable-width #t]
+                        [callback (λ (x y) (adjust-all))]
+                        [choices (list sc-install-pkg-infer
+                                       sc-install-pkg-file
+                                       sc-install-pkg-dir
+                                       sc-install-pkg-file-url
+                                       sc-install-pkg-dir-url
+                                       sc-install-pkg-github
+                                       sc-install-pkg-name)]))
+    
+    (define inferred-msg-parent (new horizontal-panel% 
+                                     [parent details-panel]
+                                     [stretchable-height #f]
+                                     [alignment '(right center)]))
+    (define inferred-msg (new message% [label ""] [parent inferred-msg-parent] [auto-resize #t]))
+    
+    (define action-choice (new choice%
+                               [label (~a sc-install-pkg-action-label ":")]
+                               [parent details-panel]
+                               [stretchable-width #t]
+                               [callback (λ (x y) (adjust-all))]
+                               [choices (list sc-install-pkg-infer
+                                              sc-install-pkg-install
+                                              sc-install-pkg-update)]))
+    (define inferred-action-msg-parent (new horizontal-panel% 
+                                            [parent details-panel]
+                                            [stretchable-height #f]
+                                            [alignment '(right center)]))
+    (define inferred-action-msg (new message% [label ""] [parent inferred-action-msg-parent] [auto-resize #t]))
+
+    
+    (define scope-panel (new horizontal-panel%
+                             [parent details-panel]
+                             [stretchable-height #f]))
+    (define scope-choice (new choice%
+                              [label (~a sc-install-pkg-scope-label ":")]
+                              [parent scope-panel]
+                              [stretchable-width #t]
+                              [callback (λ (x y) (adjust-all))]
+                              [choices (list sc-install-pkg-default
+                                             sc-install-pkg-installation
+                                             sc-install-pkg-user
+                                             sc-install-pkg-shared)]))
+    (define/private (selected-scope) (case (send scope-choice get-selection)
+                                       [(0) (default-pkg-scope)]
+                                       [(1) 'installation]
+                                       [(2) 'user]
+                                       [(3) 'shared]))
+    (define scope-default-button (new button% 
+                                      [label sc-install-pkg-set-as-default]
+                                      [font small-control-font]
+                                      [parent scope-panel]
+                                      [callback (lambda (b e)
+                                                  (in-terminal
+                                                   (lambda ()
+                                                     (define scope (selected-scope))
+                                                     (config #:scope 'installation #:set #t "default-scope" (~a scope))
+                                                     (printf "Default scope successfully changed to ~a" scope)))
+                                                  (adjust-all))]))
+    (define inferred-scope-msg-parent (new horizontal-panel% 
+                                           [parent details-panel]
+                                           [stretchable-height #f]
+                                           [alignment '(right center)]))
+    (define scope-msg (new message% [label ""] [parent inferred-scope-msg-parent] [auto-resize #t]))
+    
+    (define cb (new check-box% 
+                    [label sc-install-pkg-force?] 
+                    [parent details-panel]
+                    [callback (λ (a b) (adjust-all))]))
+
+    (new message% [parent details-panel] [label " "]) ; a spacer
+
+    (new message% [parent details-panel] [label sc-install-pkg-command-line])
+    (define cmdline-panel (new horizontal-panel% [parent details-panel] [stretchable-height #f]))
+    (new horizontal-panel% [parent cmdline-panel] [min-width 12] [stretchable-width #f])
+    (define cmdline-msg (new message% 
+                             [parent cmdline-panel]
+                             [stretchable-width #t]
+                             [label ""]
+                             [font (send (send (editor:get-standard-style-list)
+                                               find-named-style
+                                               "Standard")
+                                         get-font)]))
+    
+    (define/private (selected-type)
+      (case (send choice get-selection)
+        [(0) #f]
+        [(1) 'file]
+        [(2) 'dir]
+        [(3) 'file-url]
+        [(4) 'dir-url]
+        [(5) 'github]
+        [(6) 'name]))
+    
+    (define/private (type->str type)
+      (case type
+        [(file) sc-install-pkg-file]
+        [(name) sc-install-pkg-name]
+        [(dir) sc-install-pkg-dir]
+        [(github) sc-install-pkg-github]
+        [(file-url) sc-install-pkg-file-url]
+        [(dir-url) sc-install-pkg-dir-url]
+        [else (error 'type->str "unknown type ~s\n" type)]))
+    
+    (define currently-installed-pkgs (installed-pkg-names))
+    (define/private (get-current-action)
+      (case (send action-choice get-selection)
+        [(0) 
+         (define current-name (package-source->name (send tf get-value)))
+         (cond
+          [(and current-name (member current-name currently-installed-pkgs))
+           'update]
+          [else 
+           'install])]
+        [(1) 'install]
+        [(2) 'update]))
+    
+    
+    (define/private (adjust-all)
+      (adjust-inferred)
+      (adjust-inferred-action)
+      (adjust-checkbox)
+      (adjust-cmd-line)
+      (adjust-details-shown)
+      (adjust-browse)
+      (adjust-scope)
+      (adjust-ok))
+    
+    (define/private (adjust-checkbox)
+      (send cb enable (equal? 'install (get-current-action))))
+    
+    (define/private (adjust-inferred-action)
+      (define action (get-current-action))
+      (define new-lab
+        (cond
+         [(equal? 0 (send action-choice get-selection)) 
+          (case (get-current-action)
+            [(install) sc-action-inferred-to-be-install]
+            [(update) sc-action-inferred-to-be-update])]
+         [else ""]))
+      (send inferred-action-msg set-label new-lab))
+    
+    (define/private (adjust-ok)
+      (send ok-button set-label (case (get-current-action)
+                                  [(install) sc-install-pkg-install]
+                                  [(update) sc-install-pkg-update]))
+      (send ok-button enable (compute-cmd-line)))
+
+    (define/private (adjust-browse)
+      (define mode (send choice get-string-selection))
+      (define show? (not (or (equal? mode sc-install-pkg-github)
+                             (equal? mode sc-install-pkg-name))))
+      (define shown? (member browse-button (send source-panel get-children)))
+      (unless (eq? (and show? #t) (and shown? #t))
+        (if show?
+            (send source-panel add-child browse-button)
+            (send source-panel delete-child browse-button))))
+    
+    (define/private (adjust-details-shown)
+      (define current-details-shown-state?
+        (and (member details-panel (send details-parent get-children))
+             #t))
+      (unless (equal? current-details-shown-state? 
+                      details-shown?)
+        (cond
+         [details-shown?
+          (send details-button set-label (string-constant hide-details-button-label))
+          (send details-parent change-children
+                (λ (l) (list details-panel)))]
+         [else
+          (send details-button set-label (string-constant show-details-button-label))
+          (send details-parent change-children
+                (λ (l) '()))])))
+    
+    (define/private (adjust-inferred)
+      (define new-lab
+        (and (equal? #f (selected-type))
+             (let-values ([(_ actual-type)
+                           (package-source->name+type (send tf get-value) #f)])
+               (and actual-type
+                    (format sc-install-pkg-inferred-as (type->str actual-type))))))
+      (send inferred-msg set-label (or new-lab "")))
+
+    (define/private (adjust-scope)
+      (send scope-msg set-label (format sc-install-pkg-scope-is
+                                        (case (selected-scope)
+                                          [(installation) sc-install-pkg-installation]
+                                          [(user) sc-install-pkg-user]
+                                          [(shared) sc-install-pkg-shared])))
+      (define is-default? (let ([v (send scope-choice get-selection)])
+                            (or (zero? v)
+                                (= v (case (default-pkg-scope)
+                                       [(installation) 1]
+                                       [(user) 2]
+                                       [(shared) 3])))))
+      (define deleted? (not (member scope-default-button (send scope-panel get-children))))
+      (unless (equal? is-default? deleted?)
+        (if is-default?
+            (send scope-panel delete-child scope-default-button)
+            (send scope-panel add-child scope-default-button))))
+    
+    (define/private (adjust-cmd-line)
+      (define (convert-to-string s)
+        (cond
+         [(string? s)
+          (if (regexp-match #rx" " s)
+              (string-append "\"" s "\"")
+              s)]
+         [(keyword? s) (regexp-replace #rx"^#:" (format "~a" s) "--")]
+         [(symbol? s) (symbol->string s)]
+         [(boolean? s) #f]
+         [else (error 'convert-to-string "unk ~s" s)]))
+      (define cmd-line (compute-cmd-line))
+      (send cmdline-msg set-label
+            (if cmd-line
+                (string-append
+                 (if (eq? (system-type) 'windows)
+                     "raco.exe"
+                     "raco")
+                 " pkg "
+                 (apply string-append
+                        (add-between 
+                         (filter values (map convert-to-string cmd-line))
+                         " ")))
+                "")))
+    
+    (define/private (compute-cmd-line)
+      (define the-pkg 
+        (cond
+         [(and (equal? 'update (get-current-action))
+               (package-source->name (send tf get-value)))
+          =>
+          values]
+         [else (send tf get-value)]))
+      (and (not (equal? the-pkg ""))
+           (cons (get-current-action)
+                 (append
+                  (if (send cb get-value)
+                      '(#:force #t)
+                      '())
+                  (if (selected-type)
+                      (list '#:type (selected-type))
+                      '())
+                  (let ([scope (selected-scope)])
+                    (if (equal? scope (default-pkg-scope))
+                        '()
+                        (list '#:scope scope)))
+                  (list the-pkg)))))
+
+    (define/override (on-superwindow-show on?)
+      (when on? 
+        (reset-installed-pkgs!)))
+    
+    (adjust-all)))

collects/pkg/gui/common.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+(require racket/class
+         racket/gui/base
+         string-constants
+         racket/format)
+
+(provide really-remove?
+         sc-install-pkg-remove)
+
+(define sc-install-pkg-remove (string-constant install-pkg-remove))
+(define really-uninstall?-msg (string-constant install-pkg-really-remove?))
+
+(define (really-remove? #:parent [parent #f] names)
+  (equal? 1
+          (message-box/custom sc-install-pkg-remove
+                              (apply ~a
+                                     really-uninstall?-msg
+                                     (for/list ([n (in-list names)])
+                                       (~a "\n  " n)))
+                              sc-install-pkg-remove
+                              (string-constant cancel)
+                              #f
+                              parent
+                              '(caution default=1))))
+

collects/pkg/gui/main.rkt

@@ -0,0 +1,58 @@
+#lang racket/base
+(require racket/class
+         racket/gui/base
+         framework
+         "by-source.rkt"
+         "by-list.rkt"
+         "by-installed.rkt"
+         mrlib/terminal
+         string-constants)
+
+(define frame
+  (new frame:basic%
+       [label "Package Manager"]
+       [width 800]
+       [height 600]))
+
+(define sel-tab
+  (new tab-panel%
+       [parent (send frame get-area-container)]
+       [choices (list (string-constant install-pkg-install-by-source)
+                      (string-constant install-pkg-install-from-list)
+                      (string-constant install-pkg-install-installed))]
+       [callback (lambda (t e)
+                   (define old (send sel-panel active-child))
+                   (define new (list-ref panels (send t get-selection)))
+                   (unless (eq? new old)
+                     (send sel-panel active-child new)))]))
+
+(define sel-panel
+  (new panel:single%
+       [parent sel-tab]))
+
+(define terminal #f)
+(define (in-terminal-panel abort-label thunk)
+  (when terminal 
+    (send terminal close))
+  (define t (in-terminal 
+             #:abort-label abort-label
+             #:container (send frame get-area-container)
+             (λ (cust parent) (thunk))))
+  (set! terminal t)
+  (send sel-tab enable #f)
+  (yield (send t can-close-evt))
+  (send sel-tab enable #t))
+
+(define panels
+  (list
+   (new by-source-panel% 
+        [parent sel-panel]
+        [in-terminal in-terminal-panel])
+   (new by-list-panel% 
+        [parent sel-panel]
+        [in-terminal in-terminal-panel])
+   (new by-installed-panel%
+        [parent sel-panel]
+        [in-terminal in-terminal-panel])))
+
+(send frame show #t)

collects/string-constants/private/english-string-constants.rkt

@@ -1773,6 +1773,9 @@ please adhere to these guidelines:
   (spell-program-wrote-to-stderr-on-startup "The spell program (~a) printed an error message:")
   
   ;; GUI for installing a pkg package; available via File|Install Package...
+  (install-pkg-install-by-source "Install by Source") ; tab label
+  (install-pkg-install-from-list "Install from List") ; tab label
+  (install-pkg-install-installed "Installed")         ; tab label
   (install-pkg-menu-item... "Install Package...")
   (install-pkg-dialog-title "Install Package")
   (install-pkg-source-label "Package Source")
@@ -1786,10 +1789,35 @@ please adhere to these guidelines:
   (install-pkg-name "Name (consulting resolver)")
   (install-pkg-inferred-as "Type inferred to be ~a")
   (install-pkg-force? "Overwrite Existing?")
-  (install-pkg-command-line "Equivalent Command Line Invocation:")
+  (install-pkg-command-line "Equivalent command line invocation:")
   (install-pkg-error-installing-title "Error Installing Package")
   (install-pkg-action-label "Action to Take")
   (install-pkg-install "Install")
   (install-pkg-update "Update")
-  (install-pkg-action-inferred-to-be-update "Action Inferred to be Update")
+  (install-pkg-remove "Remove")
-  (install-pkg-action-inferred-to-be-install "Action Inferred to be Install"))
+  (install-pkg-action-inferred-to-be-update "Action inferred to be Update")
+  (install-pkg-action-inferred-to-be-install "Action inferred to be Install")
+  (install-pkg-default "Default")
+  (install-pkg-scope-label "Package Scope")
+  (install-pkg-installation "Specific Racket Installation")
+  (install-pkg-user "Specific User and Racket Version")
+  (install-pkg-shared "Specific User and All Racket Versions")
+  (install-pkg-set-as-default "Set as Default")
+  (install-pkg-scope-is "Package scope is ~a") ; ~a gets install-pkg-{installation,user,shared}
+  (install-pkg-select-package-directory "Select Package Directory")
+  (install-pkg-select-package-file "Select Package File")
+  (install-pkg-update-package-list "Update Package List")
+  (install-pkg-stop-update "Stop Update")
+  (install-pkg-filter "Filter")
+  (install-pkg-update-catalogs? "Update database to match the configured set of catalogs?")
+  (install-pkg-currently-configured-are "The currently configured catalogs are")
+  (install-pkg-database-recorded-are "The database-recorded catalogs are")
+  (install-pkg-update-catalogs "Update")
+  (install-pkg-do-not-update-catalogs "Don't Update")
+  (install-pkg-really-remove? "Are you sure you want to remove the following selected packages?")
+  (install-pkg-abort-install "Abort Install")
+  (install-pkg-abort-update "Abort Update")
+  (install-pkg-abort-remove "Abort Remove")
+  (install-pkg-abort-generic-action "Abort Action")
+  
+  )