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

* Remember values in "install .plt" dialog

Browse Source 
* Add "http://" prefix to a url if it looks like it's missing
* Focus on the text field when switching tabs

svn: r17843
This commit is contained in:
Eli Barzilay 2010-01-26 20:55:13 +00:00
parent cba82db678
commit 024f635203
2 changed files with 76 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
collects/drscheme/private/frame.ss
View File

@ -300,108 +300,98 @@
;; asks the user for a .plt file, either from the web or from ;; asks the user for a .plt file, either from the web or from
;; a file on the disk and installs it. ;; a file on the disk and installs it.
(define (install-plt-file parent) (define (install-plt-file parent)
(define pref (preferences:get 'drscheme:install-plt-dialog))
(define dialog (define dialog
(instantiate dialog% () (new dialog% [parent parent]
(parent parent) [label (string-constant install-plt-file-dialog-title)]
(alignment '(left center)) [alignment '(left center)]))
(label (string-constant install-plt-file-dialog-title))))
(define tab-panel (define tab-panel
(instantiate tab-panel% () (new tab-panel% [parent dialog]
(parent dialog) [callback (λ (x y) (update-panels))]
(callback (λ (x y) (update-panels))) [choices (list (string-constant install-plt-web-tab)
(choices (list (string-constant install-plt-web-tab) (string-constant install-plt-file-tab))]))
(string-constant install-plt-file-tab))))) (define outer-swapping-panel
(define outer-swapping-panel (instantiate horizontal-panel% () (new horizontal-panel% [parent tab-panel]
(parent tab-panel) [stretchable-height #f]))
(stretchable-height #f))) (define spacing-panel
(define spacing-panel (instantiate horizontal-panel% () (new horizontal-panel% [parent outer-swapping-panel]
(stretchable-width #f) [stretchable-width #f]
(parent outer-swapping-panel) [min-width 20]))
(min-width 20))) (define swapping-panel
(define swapping-panel (instantiate panel:single% () (new panel:single% [parent outer-swapping-panel]
(parent outer-swapping-panel) [alignment '(left center)]
(alignment '(left center)) [stretchable-width #t] [stretchable-height #f]))
(stretchable-width #t) (define file-panel
(stretchable-height #f))) (new horizontal-panel% [parent swapping-panel]
(define file-panel (instantiate horizontal-panel% () [stretchable-width #t] [stretchable-height #f]))
(parent swapping-panel) (define url-panel
(stretchable-width #t) (new horizontal-panel% [parent swapping-panel]
(stretchable-height #f))) [stretchable-height #f]))
(define url-panel (instantiate horizontal-panel% () (define button-panel
(parent swapping-panel) (new horizontal-panel% [parent dialog]
(stretchable-height #f))) [stretchable-height #f] [alignment '(right center)]))
(define button-panel (instantiate horizontal-panel% () (define file-text-field
(parent dialog) (new text-field% [parent file-panel]
(stretchable-height #f) [callback void] [min-width 300] [stretchable-width #t]
(alignment '(right center)))) [init-value (caddr pref)]
(define file-text-field (instantiate text-field% () [label (string-constant install-plt-filename)]))
(parent file-panel) (define file-button
(callback void) (new button% [parent file-panel]
(min-width 300) [callback (λ (x y) (browse))]
(stretchable-width #t) [label (string-constant browse...)]))
(label (string-constant install-plt-filename)))) (define url-text-field
(define file-button (instantiate button% () (new text-field% [parent url-panel]
(parent file-panel) [min-width 300] [stretchable-width #t] [callback void]
(label (string-constant browse...)) [init-value (cadr pref)]
(callback (λ (x y) (browse))))) [label (string-constant install-plt-url)]))
(define url-text-field (instantiate text-field% ()
(parent url-panel)
(label (string-constant install-plt-url))
(min-width 300)
(stretchable-width #t)
(callback void)))
(define-values (ok-button cancel-button) (define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons (gui-utils:ok/cancel-buttons
button-panel button-panel
(λ (x y) (λ (x y) (set! cancel? #f) (send dialog show #f))
(set! cancel? #f) (λ (x y) (send dialog show #f))))
(send dialog show #f))
(λ (x y)
(send dialog show #f))))
;; browse : -> void ;; browse : -> void
;; gets the name of a file from the user and ;; gets the name of a file from the user and updates file-text-field
;; updates file-text-field
(define (browse) (define (browse)
(let ([filename (finder:get-file #f "" #f "" dialog)]) (let ([filename (finder:get-file #f "" #f "" dialog)])
(when filename (when filename
(send file-text-field set-value (path->string filename))))) (send file-text-field set-value (path->string filename)))))
;; from-web? : -> boolean ;; from-web? : -> boolean
;; returns #t if the user has selected a web address ;; returns #t if the user has selected a web address
(define (from-web?) (define (from-web?)
(zero? (send tab-panel get-selection))) (zero? (send tab-panel get-selection)))
(define cancel? #t) (define cancel? #t)
(define (update-panels) (define (update-panels)
(send swapping-panel active-child (define w? (from-web?))
(if (from-web?) (define t (if w? url-text-field file-text-field))
url-panel (send swapping-panel active-child (if w? url-panel file-panel))
file-panel))) (send t focus)
(send (send t get-editor) set-position
0 (string-length (send t get-value))))
;; initialize
(send tab-panel set-selection (if (car pref) 0 1))
(update-panels) (update-panels)
(send dialog show #t) (send dialog show #t)
(preferences:set 'drscheme:install-plt-dialog
(list (from-web?)
(send url-text-field get-value)
(send file-text-field get-value)))
(cond (cond
[cancel? (void)] [cancel? (void)]
[(from-web?) [(from-web?)
(install-plt-from-url (trim-whitespace (send url-text-field get-value)) parent)] (install-plt-from-url
[else (let* ([url (send url-text-field get-value)]
(parameterize ([error-display-handler drscheme:init:original-error-display-handler]) ;; trim whitespaces
(run-installer (string->path (send file-text-field get-value))))])) [url (regexp-replace #rx"^ +" url "")]
[url (regexp-replace #rx" +$" url "")])
;; trim-whitespace: string -> string (if (regexp-match? #rx"^(?:[^/:]*://|$)" url)
;; Trims the whitespace surrounding a string. url
(define (trim-whitespace a-str) (string-append "http://" url)))
(cond parent)]
[(regexp-match #px"^\\s*(.*[^\\s])\\s*$" [else (parameterize ([error-display-handler
a-str) drscheme:init:original-error-display-handler])
=> second] (run-installer
[else (string->path (send file-text-field get-value))))]))
a-str]))
;; install-plt-from-url : string (union #f dialog%) -> void ;; install-plt-from-url : string (union #f dialog%) -> void
;; downloads and installs a .plt file from the given url ;; downloads and installs a .plt file from the given url
(define (install-plt-from-url s-url parent) (define (install-plt-from-url s-url parent)

5
collects/drscheme/private/main.ss
View File

@ -152,6 +152,11 @@
(λ (x) (and (list? x) (λ (x) (and (list? x)
(andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) (andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x)))
x)))) x))))
(preferences:set-default 'drscheme:install-plt-dialog
'(#t "" "") ; url-selected?, url string, file string
(λ (x) (and (list? x) (= 3 (length x))
(boolean? (car x))
(andmap string? (cdr x)))))
(preferences:set-un/marshall (preferences:set-un/marshall
'drscheme:user-defined-keybindings 'drscheme:user-defined-keybindings