adjust package manager gui to separate out (and make simpler looking)

the package installer

and make DrRacket have two separate menu items, one for installing a package
(which now looks simpler again) and one for doing all of the things you can
currently do with the package system in a GUI

collects/drracket/private/frame.rkt

@@ -3,18 +3,19 @@
 (module install-pkg racket/base
   (require racket/class
            pkg/gui/main)
-  (provide install-pkg)
+  (provide install-pkg
+           pkg-manager)
 
   (define pkg-gui #f)
   
-  (define (install-pkg parent wrap-terminal-action)
+  (define (pkg-manager wrap-terminal-action)
     (if pkg-gui
         (send pkg-gui show #t)
-        (set! pkg-gui (make-pkg-gui #:wrap-terminal-action wrap-terminal-action)))))
-
-(module main racket
-  (require (submod ".." install-pkg))
-  (install-pkg #f))
+        (set! pkg-gui (make-pkg-gui #:wrap-terminal-action wrap-terminal-action))))
+  
+  (define (install-pkg parent wrap-terminal-action)
+    (make-pkg-installer #:parent parent 
+                        #:wrap-terminal-action wrap-terminal-action)))
 
 (require string-constants
          racket/match
@@ -209,6 +210,15 @@
                               (lambda (thunk)
                                 (parameterize ([error-display-handler drracket:init:original-error-display-handler])
                                   (thunk)))))])
+        (new separator-menu-item% [parent file-menu])
+        (new menu-item% 
+             [label (string-constant pkg-manager-menu-item)]
+             [parent file-menu]
+             [callback
+              (λ (item evt) 
+                (pkg-manager (lambda (thunk)
+                               (parameterize ([error-display-handler drracket:init:original-error-display-handler])
+                                 (thunk)))))])
         (super file-menu:between-open-and-revert file-menu))
       
       (define/override (file-menu:between-print-and-close menu)

collects/pkg/gui/by-source.rkt

@@ -49,7 +49,7 @@
 (define by-source-panel%
   (class vertical-panel%
     (init-field [in-terminal in-terminal])
-
+    
     (super-new)
     
     (inherit get-top-level-window)
@@ -94,6 +94,7 @@
                                                                                f))))
                                              (adjust-all)))]))
     
+    (define/public (get-button-panel) button-panel)
     (define button-panel (new horizontal-panel% 
                               [parent this] 
                               [stretchable-height #f]))
@@ -135,8 +136,8 @@
                                 [parent button-panel]
                                 [callback
                                  (λ (a b)
-                                    (set! details-shown? (not details-shown?))
-                                    (adjust-all))]))
+                                   (set! details-shown? (not details-shown?))
+                                   (adjust-all))]))
 
     (send details-parent change-children (λ (l) '()))
     (define choice (new choice%
@@ -219,12 +220,13 @@
     (new horizontal-panel% [parent cmdline-panel] [min-width 12] [stretchable-width #f])
     (define cmdline-msg (new message% 
                              [parent cmdline-panel]
-                             [stretchable-width #t]
+                             [auto-resize #t]
                              [label ""]
                              [font (send (send (editor:get-standard-style-list)
                                                find-named-style
                                                "Standard")
                                          get-font)]))
+    (new horizontal-panel% [parent cmdline-panel] [stretchable-width #t])
     
     (define/private (selected-type)
       (case (send choice get-selection)

collects/pkg/gui/main.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
          racket/gui/base
+         racket/contract/base
          framework
          "by-source.rkt"
          "by-list.rkt"
@@ -8,18 +9,104 @@
          mrlib/terminal
          string-constants)
 
-(provide make-pkg-gui)
+(provide
+ (contract-out
+  [make-pkg-gui
+   (->* ()
+        (#:wrap-terminal-action 
+         (-> (-> any) any) 
+         #:initial-tab 
+         (or/c 'by-source 'from-list 'installed))
+        (is-a?/c top-level-window<%>))]
+  [make-pkg-installer
+   (->* ()
+        (#:parent
+         (or/c #f (is-a?/c top-level-window<%>))
+         #:wrap-terminal-action 
+         (-> (-> any) any))
+        (is-a?/c top-level-window<%>))]))
+
+(define pkg-gui-frame% 
+  (class (frame:standard-menus-mixin
+          (frame:status-line-mixin
+           frame:basic%))
+    (super-new)
+    ;; no menu separator:
+    (define/override (edit-menu:between-select-all-and-find m) (void))))
+
+(define (make-pkg-installer #:parent 
+                            [parent #f]
+                            #:wrap-terminal-action 
+                            [wrap-terminal-action (λ (t) (t))])
+  
+  (define allow-close? #t)
+  
+  (define dlg
+    (new (class dialog%
+           (define/augment (can-close?)
+             allow-close?)
+           (super-new
+            [parent parent]
+            [label "Package Installer"]))))
+
+  (define terminal #f)
+  (define (in-terminal-panel abort-label thunk)
+    (send dlg begin-container-sequence)
+    (when terminal (send terminal close))
+    (define t (in-terminal 
+               #:abort-label abort-label
+               #:canvas-min-height 400
+               #:container dlg
+               #:close-button? #f
+               (λ (cust parent) (wrap-terminal-action thunk))))
+    (send dlg reflow-container)
+    (unless terminal (send dlg center))
+    (set! terminal t)
+    (disallow-close)
+    (send dlg end-container-sequence)
+    (yield (send t can-close-evt))
+    (allow-close))
+  
+  (define (disallow-close)
+    (set! allow-close? #f)
+    (send close enable #f))
+  
+  (define (allow-close)
+    (set! allow-close? #t)
+    (send close enable #t))
+
+  (define by-source-panel
+    (new by-source-panel% 
+         [parent dlg]
+         [in-terminal in-terminal-panel]))
+  
+  (define close (new button% 
+                     [label (string-constant close)] 
+                     [parent (send by-source-panel get-button-panel)]
+                     [callback
+                      (λ (x y)
+                        (send dlg show #f))]))
+  
+  (send dlg show #t)
+
+  dlg)
+
+(define (make-pkg-gui #:wrap-terminal-action 
+                      [wrap-terminal-action (lambda (thunk) (thunk))]
+                      #:initial-tab [initial-tab 'installed])
 
-(define (make-pkg-gui #:wrap-terminal-action [wrap-terminal-action (lambda (thunk) (thunk))])
   (define frame
-    (new (class frame:standard-menus%
-           (super-new)
-           ;; no menu separator:
-           (define/override (edit-menu:between-select-all-and-find m) (void)))
+    (new pkg-gui-frame%
          [label "Package Manager"]
          [width 800]
          [height 600]))
 
+  (define (update-sel-panel-active)
+    (define old (send sel-panel active-child))
+    (define new (list-ref (send sel-panel get-children) (send sel-tab get-selection)))
+    (unless (eq? new old)
+      (send sel-panel active-child new)))
+  
   (define sel-tab
     (new tab-panel%
          [parent (send frame get-area-container)]
@@ -27,10 +114,7 @@
                         (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)))]))
+                     (update-sel-panel-active))]))
 
   (define sel-panel
     (new panel:single%
@@ -49,21 +133,26 @@
     (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])))
-
+  (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 sel-tab set-selection
+        (case initial-tab
+          [(by-source) 0]
+          [(from-list) 1]
+          [(installed) 2]))
+  (update-sel-panel-active)
+  
   (send frame show #t)
 
   frame)
 
 (module+ main
-  (void (make-pkg-gui)))
+  (void (make-pkg-installer)))

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

@@ -1821,5 +1821,7 @@ please adhere to these guidelines:
   (install-pkg-abort-update "Abort Update")
   (install-pkg-abort-remove "Abort Remove")
   (install-pkg-abort-generic-action "Abort Action")
+  (install-pkg-show-all-options "Show All Options")
+  (pkg-manager-menu-item "Package Manager...")
   
   )