suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add support for updating packages via

Browse Source 
drracket's "install package" menu item

It will infer whether to use 'raco pkg update' or
'raco pkg install' based on the currently installed
set of packages (but, of course, the details
section of the dialog lets you override this inference
if necessary)
This commit is contained in:
Robby Findler 2013-04-05 09:40:07 -05:00
parent e3b580c200
commit e34e63b323
2 changed files with 79 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/drracket/private/frame.rkt
View File

@ -5,6 +5,7 @@
racket/class
string-constants
pkg/name
pkg/lib
racket/list
framework)
(provide install-pkg)
@ -23,6 +24,12 @@
(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)
@ -84,6 +91,21 @@
[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]
@ -121,12 +143,42 @@
[(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)))
@ -173,7 +225,7 @@
(if (eq? (system-type) 'windows)
"raco.exe"
"raco")
" pkg install "
" pkg "
(apply string-append
(add-between
(filter values (map convert-to-string cmd-line))
@ -181,16 +233,23 @@
"")))
(define (compute-cmd-line)
(define the-pkg (send tf get-value))
(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 ""))
(append
(if (send cb get-value)
'(#:force #t)
'())
(if (selected-type)
(list '#:type (selected-type))
'())
(list 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)
@ -394,7 +453,11 @@
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
(in-terminal
#:title (string-constant install-pkg-dialog-title)
(λ (cust parent) (apply install res))))))])
(λ (cust parent)
(define action (case (car res)
[(install) install]
[(update) update]))
(apply action (cdr res)))))))])
(super file-menu:between-open-and-revert file-menu))
(define/override (file-menu:between-print-and-close menu)

6
collects/string-constants/private/english-string-constants.rkt
View File

@ -1788,4 +1788,8 @@ please adhere to these guidelines:
(install-pkg-force? "Overwrite Existing?")
(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-action-inferred-to-be-install "Action Inferred to be Install"))