From 05c0299be4398cf570972d1baf81a78e5e3c5552 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Apr 2013 09:32:12 -0600 Subject: [PATCH] switch DrRacket's "Install Package..." to the new package manager GUI --- collects/drracket/private/frame.rkt | 278 ++-------------------------- collects/pkg/gui/main.rkt | 97 +++++----- 2 files changed, 67 insertions(+), 308 deletions(-) diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index 83ef389175..ab95c97ba9 100644 --- a/collects/drracket/private/frame.rkt +++ b/collects/drracket/private/frame.rkt @@ -1,262 +1,16 @@ #lang racket/base (module install-pkg racket/base - (require racket/gui/base - racket/class - string-constants - pkg/name - pkg/lib - racket/list - framework) + (require racket/class + pkg/gui/main) (provide install-pkg) - - (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)) - - (preferences:set-default 'drracket:gui-installer-pkg-source "" string?) - - (define (install-pkg parent) - (define dlg (new dialog% - [parent parent] - [label sc-install-pkg-dialog-title] - [alignment '(right center)])) - (define tf (new text-field% - [parent dlg] - [min-width 600] - [label 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 details-parent (new vertical-panel% [parent dlg])) - (define details-panel (new group-box-panel% - [label (string-constant autosave-details)] - [parent details-parent] - [alignment '(left center)])) - (define button-panel (new horizontal-panel% - [parent dlg] - [stretchable-height #f] - [alignment '(right center)])) - - (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))])) - (new horizontal-panel% [parent button-panel]) - (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons button-panel - (λ (_1 _2) - (set! ok? #t) - (send dlg show #f)) - (λ (_1 _2) (send dlg show #f)))) - (send details-parent change-children (λ (l) '())) - (define choice (new choice% - [label 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 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 cb (new check-box% - [label sc-install-pkg-force?] - [parent details-panel] - [callback (λ (a b) (adjust-all))])) - - (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 (selected-type) - (case (send choice get-selection) - [(0) #f] - [(1) 'file] - [(2) 'dir] - [(3) 'file-url] - [(4) 'dir-url] - [(5) 'github] - [(6) 'name])) - - (define (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 (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 (adjust-all) - (adjust-inferred) - (adjust-inferred-action) - (adjust-checkbox) - (adjust-cmd-line) - (adjust-details-shown) - (adjust-ok/cancel)) - - (define (adjust-checkbox) - (send cb enable (equal? 'install (get-current-action)))) - - (define (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 (adjust-ok/cancel) - (send ok-button enable (compute-cmd-line))) - - (define (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 (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 (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 (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)) - '()) - (list the-pkg))))) - - (adjust-all) - - (define ok? #f) - - (send dlg show #t) - (and ok? (compute-cmd-line)))) + (define pkg-gui #f) + + (define (install-pkg parent 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)) @@ -450,17 +204,11 @@ [label (string-constant install-pkg-menu-item...)] [parent file-menu] [callback - (λ (item evt) - (define res (install-pkg this)) - (when res - (parameterize ([error-display-handler drracket:init:original-error-display-handler]) - (in-terminal - #:title (string-constant install-pkg-dialog-title) - (λ (cust parent) - (define action (case (car res) - [(install) install] - [(update) update])) - (apply action (cdr res)))))))]) + (λ (item evt) + (install-pkg this + (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/main.rkt b/collects/pkg/gui/main.rkt index 4b3392f430..affb862f76 100644 --- a/collects/pkg/gui/main.rkt +++ b/collects/pkg/gui/main.rkt @@ -8,51 +8,62 @@ mrlib/terminal string-constants) -(define frame - (new frame:basic% - [label "Package Manager"] - [width 800] - [height 600])) +(provide make-pkg-gui) -(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 (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))) + [label "Package Manager"] + [width 800] + [height 600])) -(define sel-panel - (new panel:single% - [parent sel-tab])) + (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 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 sel-panel + (new panel:single% + [parent sel-tab])) -(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]))) + (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) (wrap-terminal-action thunk)))) + (set! terminal t) + (send sel-tab enable #f) + (yield (send t can-close-evt)) + (send sel-tab enable #t)) -(send frame show #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) + + frame) + +(module+ main + (void (make-pkg-gui)))