diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index ab95c97ba9..eeaa3bae04 100644 --- a/collects/drracket/private/frame.rkt +++ b/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) diff --git a/collects/pkg/gui/by-source.rkt b/collects/pkg/gui/by-source.rkt index 7d14caaa4c..764a4f79a3 100644 --- a/collects/pkg/gui/by-source.rkt +++ b/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) diff --git a/collects/pkg/gui/main.rkt b/collects/pkg/gui/main.rkt index affb862f76..0470de1f4b 100644 --- a/collects/pkg/gui/main.rkt +++ b/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))) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index fdf6d8b8f7..0c1f01b3aa 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/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...") )