From d94a4cd830d30b4681f952d5d94f5c358324cae3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Jul 2013 14:06:25 -0600 Subject: [PATCH] add migration panel to GUI package manager Also add "gui-pkg-manager" packages, including a "Racket Package Manager" GUI application (that needs a better icon). The package that supplies "Racket Package Manager" is not in the main distribution, since DrRacket already includes the GUI package manager. --- pkgs/drracket-pkgs/drracket/info.rkt | 3 +- .../gui-pkg-manager-lib/info.rkt | 7 ++ .../pkg/gui/by-installed.rkt | 0 .../gui-pkg-manager-lib}/pkg/gui/by-list.rkt | 0 .../pkg/gui/by-migrate.rkt | 90 +++++++++++++++++++ .../pkg/gui/by-source.rkt | 0 .../gui-pkg-manager-lib}/pkg/gui/common.rkt | 0 .../gui-pkg-manager-lib}/pkg/gui/main.rkt | 12 ++- .../gui-pkg-manager/info.rkt | 8 ++ .../gui-pkg-manager/pkg/gui/info.rkt | 4 + .../gui-pkg-manager/pkg/gui/start.rkt | 5 ++ pkgs/plt-services/info.rkt | 1 + .../private/english-string-constants.rkt | 12 ++- racket/collects/pkg/lib.rkt | 17 ++-- 14 files changed, 146 insertions(+), 13 deletions(-) create mode 100644 pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/info.rkt rename pkgs/{drracket-pkgs/drracket => gui-pkg-manager-pkgs/gui-pkg-manager-lib}/pkg/gui/by-installed.rkt (100%) rename pkgs/{drracket-pkgs/drracket => gui-pkg-manager-pkgs/gui-pkg-manager-lib}/pkg/gui/by-list.rkt (100%) create mode 100644 pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-migrate.rkt rename pkgs/{drracket-pkgs/drracket => gui-pkg-manager-pkgs/gui-pkg-manager-lib}/pkg/gui/by-source.rkt (100%) rename pkgs/{drracket-pkgs/drracket => gui-pkg-manager-pkgs/gui-pkg-manager-lib}/pkg/gui/common.rkt (100%) rename pkgs/{drracket-pkgs/drracket => gui-pkg-manager-pkgs/gui-pkg-manager-lib}/pkg/gui/main.rkt (93%) create mode 100644 pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/info.rkt create mode 100644 pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/info.rkt create mode 100644 pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/start.rkt diff --git a/pkgs/drracket-pkgs/drracket/info.rkt b/pkgs/drracket-pkgs/drracket/info.rkt index a67c93ce49..730e9b2ef2 100644 --- a/pkgs/drracket-pkgs/drracket/info.rkt +++ b/pkgs/drracket-pkgs/drracket/info.rkt @@ -34,7 +34,8 @@ "net-lib" "srfi-lib" "srfi-doc" - "unstable")) + "unstable" + "gui-pkg-manager-lib")) (define build-deps '("compatibility-doc" "draw-doc" "errortrace-doc" diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/info.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/info.rkt new file mode 100644 index 0000000000..067f84f430 --- /dev/null +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/info.rkt @@ -0,0 +1,7 @@ +#lang info + +(define collection 'multi) + +(define deps '("base" + "gui-lib" + "string-constants-lib")) diff --git a/pkgs/drracket-pkgs/drracket/pkg/gui/by-installed.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-installed.rkt similarity index 100% rename from pkgs/drracket-pkgs/drracket/pkg/gui/by-installed.rkt rename to pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-installed.rkt diff --git a/pkgs/drracket-pkgs/drracket/pkg/gui/by-list.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-list.rkt similarity index 100% rename from pkgs/drracket-pkgs/drracket/pkg/gui/by-list.rkt rename to pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-list.rkt diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-migrate.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-migrate.rkt new file mode 100644 index 0000000000..e5128a9379 --- /dev/null +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-migrate.rkt @@ -0,0 +1,90 @@ +#lang racket/base + +(require racket/gui/base + racket/class + racket/format + racket/file + string-constants + setup/dirs + pkg + "common.rkt") + +(provide by-migrate-panel%) + +(define by-migrate-panel% + (class vertical-panel% + (init-field [in-terminal in-terminal]) + (super-new) + + (inherit get-top-level-window) + + (define choices-panel (new horizontal-panel% + [parent this] + [alignment '(center top)])) + + (define versions (new list-box% + [label (~a (string-constant install-pkg-migrate-available-installations) + ":")] + [choices null] + [parent choices-panel] + [callback (λ (_1 _2) (adjust-all))])) + + (define button-panel (new vertical-panel% + [parent choices-panel] + [stretchable-height #f] + [stretchable-width #f] + [alignment '(center center)])) + + (define migrate-from-button (new button% + [parent button-panel] + [label (string-constant install-pkg-migrate-from)] + [callback (lambda (b e) + (in-terminal + (string-constant install-pkg-abort-migrate) + (lambda () + (pkg-migrate-command + (send versions get-string-selection)))))] + [style '(border)])) + + (define remove-button (new button% + [parent button-panel] + [label (string-constant install-pkg-remove)] + [callback (lambda (b e) + (remove-package-info + (send versions get-string-selection)))])) + + (define (remove-package-info vers) + (when (= 1 (message-box/custom (format (string-constant install-pkg-packages-for) vers) + (format + (string-constant install-pkg-really-remove-installation) + vers) + (string-constant install-pkg-remove) + (string-constant install-pkg-do-not-remove) + #f + (get-top-level-window) + '(caution default=1))) + (delete-directory/files (build-path (find-system-path 'addon-dir) vers "pkgs")) + (update-list!) + (adjust-all))) + + (define (update-list!) + (define d (find-system-path 'addon-dir)) + (define dirs (for/list ([p (in-list (directory-list d))] + #:when (let ([p (build-path d p "pkgs" "pkgs.rktd")]) + (file-exists? p)) + #:unless (equal? (path-element->string p) + (get-installation-name))) + (path-element->string p))) + (send versions set dirs)) + + (define (adjust-all) + (define s (send versions get-selection)) + (send migrate-from-button enable s) + (send remove-button enable s)) + + (define/override (on-superwindow-show on?) + (when on? + (update-list!) + (adjust-all))) + + (adjust-all))) diff --git a/pkgs/drracket-pkgs/drracket/pkg/gui/by-source.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-source.rkt similarity index 100% rename from pkgs/drracket-pkgs/drracket/pkg/gui/by-source.rkt rename to pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/by-source.rkt diff --git a/pkgs/drracket-pkgs/drracket/pkg/gui/common.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/common.rkt similarity index 100% rename from pkgs/drracket-pkgs/drracket/pkg/gui/common.rkt rename to pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/common.rkt diff --git a/pkgs/drracket-pkgs/drracket/pkg/gui/main.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/main.rkt similarity index 93% rename from pkgs/drracket-pkgs/drracket/pkg/gui/main.rkt rename to pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/main.rkt index a93fea895a..4483cc1eb5 100644 --- a/pkgs/drracket-pkgs/drracket/pkg/gui/main.rkt +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager-lib/pkg/gui/main.rkt @@ -6,6 +6,7 @@ "by-source.rkt" "by-list.rkt" "by-installed.rkt" + "by-migrate.rkt" mrlib/terminal string-constants) @@ -16,7 +17,7 @@ (#:wrap-terminal-action (-> (-> any) any) #:initial-tab - (or/c 'by-source 'from-list 'installed)) + (or/c 'by-source 'from-list 'installed 'migrate)) (is-a?/c top-level-window<%>))] [make-pkg-installer (->* () @@ -117,7 +118,8 @@ [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))] + (string-constant install-pkg-install-installed) + (string-constant install-pkg-migrate-from))] [callback (lambda (t e) (update-sel-panel-active))])) @@ -147,12 +149,16 @@ (new by-installed-panel% [parent sel-panel] [in-terminal in-terminal-panel]) + (new by-migrate-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])) + [(installed) 2] + [(migrate) 3])) (update-sel-panel-active) (send frame show #t) diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/info.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/info.rkt new file mode 100644 index 0000000000..16986c53c1 --- /dev/null +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/info.rkt @@ -0,0 +1,8 @@ +#lang info + +(define collection 'multi) + +(define deps '("gui-pkg-manager-lib" + "base")) + +(define implies '("gui-pkg-manager-lib")) diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/info.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/info.rkt new file mode 100644 index 0000000000..8ec8966dce --- /dev/null +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/info.rkt @@ -0,0 +1,4 @@ +#lang info + +(define gracket-launcher-names '("Racket Package Manager")) +(define gracket-launcher-libraries '("start.rkt")) diff --git a/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/start.rkt b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/start.rkt new file mode 100644 index 0000000000..cff81165f5 --- /dev/null +++ b/pkgs/gui-pkg-manager-pkgs/gui-pkg-manager/pkg/gui/start.rkt @@ -0,0 +1,5 @@ +#lang racket/base + +(require pkg/gui/main) + +(void (make-pkg-gui)) diff --git a/pkgs/plt-services/info.rkt b/pkgs/plt-services/info.rkt index 988c791c1a..3b75afee35 100644 --- a/pkgs/plt-services/info.rkt +++ b/pkgs/plt-services/info.rkt @@ -11,6 +11,7 @@ "main-distribution-test" "distro-build" "honu" + "gui-pkg-manager" ;; Actual dependencies: "eli-tester" diff --git a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt index 441e6259a5..b22dc6b61e 100644 --- a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt @@ -1785,6 +1785,7 @@ please adhere to these guidelines: (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-migrate-from "Migrate From") ; tab label (install-pkg-menu-item... "Install Package...") (install-pkg-dialog-title "Install Package") (install-pkg-source-label "Package Source") @@ -1796,7 +1797,7 @@ please adhere to these guidelines: (install-pkg-file-url "URL File") (install-pkg-github "Github") (install-pkg-name "Name (consulting resolver)") - (install-pkg-inferred-as "Type inferred to be ~a") + (install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...} (install-pkg-force? "Overwrite Existing?") (install-pkg-command-line "Equivalent command line invocation:") (install-pkg-error-installing-title "Error Installing Package") @@ -1804,6 +1805,7 @@ please adhere to these guidelines: (install-pkg-install "Install") (install-pkg-update "Update") (install-pkg-remove "Remove") + (install-pkg-do-not-remove "Don't Remove") (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") @@ -1827,8 +1829,14 @@ please adhere to these guidelines: (install-pkg-abort-install "Abort Install") (install-pkg-abort-update "Abort Update") (install-pkg-abort-remove "Abort Remove") + (install-pkg-abort-migrate "Abort Migrate") (install-pkg-abort-generic-action "Abort Action") (install-pkg-show-all-options "Show All Options") - (pkg-manager-menu-item "Package Manager...") + (install-pkg-migrate-available-installations "Available Installations") + (install-pkg-inferred-as "Type inferred to be ~a") ; ~a gets install-pkg-{file,dir,...} + (pkg-manager-menu-item "Package Manager...") + ;; where ~a gets an installation name: + (install-pkg-packages-for "Packages for ~a") + (install-pkg-really-remove-installation "Are you sure you want to remove all installed packages and information for ~a?") ) diff --git a/racket/collects/pkg/lib.rkt b/racket/collects/pkg/lib.rkt index 44b7edebc2..22c0215caf 100644 --- a/racket/collects/pkg/lib.rkt +++ b/racket/collects/pkg/lib.rkt @@ -1656,13 +1656,16 @@ (printf " ~a from ~a\n" n (pkg-desc-source d))]))])) (if (null? to-install) 'skip - (pkg-install to-install - #:force? force? - #:ignore-checksums? ignore-checksums? - #:skip-installed? #t - #:dep-behavior (or dep-behavior 'search-auto) - #:quiet? quiet? - #:strip strip-mode))) + (begin0 + (pkg-install to-install + #:force? force? + #:ignore-checksums? ignore-checksums? + #:skip-installed? #t + #:dep-behavior (or dep-behavior 'search-auto) + #:quiet? quiet? + #:strip strip-mode) + (unless quiet? + (printf "Packages migrated\n"))))) (define (pkg-config config:set key+vals) (cond