diff --git a/drracket-core-lib/browser/external.rkt b/drracket-core-lib/browser/external.rkt index 2fba81299..8c701a75e 100644 --- a/drracket-core-lib/browser/external.rkt +++ b/drracket-core-lib/browser/external.rkt @@ -40,10 +40,11 @@ ;; sync-current-proxy-servers : proxy-pref -> void ;; syncs current-proxy-servers parameter with the proxy-pref-val (define (sync-current-proxy-servers pref-val) - (let* ([ops (current-proxy-servers)] - [removed (remove-all-proxies "http" ops)]) - (current-proxy-servers - (if pref-val (cons pref-val removed) removed)))) + (define ops (current-proxy-servers)) + (define removed (remove-all-proxies "http" ops)) + (current-proxy-servers (if pref-val + (cons pref-val removed) + removed))) (define (remove-all-proxies scheme proxies) (filter (lambda (x) (and (pair? x) (not (equal? (car x) scheme)))) @@ -84,9 +85,8 @@ (loop (add1 tries))))))) (define unix-browser-names - (map (lambda (s) - (string-titlecase (regexp-replace* #rx"-" (symbol->string s) " "))) - raw:unix-browser-list)) + (for/list ([s (in-list raw:unix-browser-list)]) + (string-titlecase (regexp-replace* #rx"-" (symbol->string s) " ")))) ;; : (U str #f) -> (U symbol #f) ;; to prompt the user for a browser preference @@ -94,38 +94,37 @@ ;; and in that case, the user can choose to use the internal ;; broswer. (define (choose-browser url) - (let* ([title (string-constant choose-browser)] - [d (make-object dialog% title)] - [main-pane (make-object vertical-pane% d)] - [internal-ok? (not url)] - [ok? #f] - [orig-external (fw:preferences:get 'external-browser)]) - (make-object message% title main-pane) - ;; No need to show the URL (it can be very long) - ;; (when url - ;; (make-object message% (format "URL: ~a" url) main-pane)) - (let-values ([(panel callbacks) (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))]) - (let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane) - (alignment '(right center)))] - [(ok-button cancel-button) - (fw:gui-utils:ok/cancel-buttons - button-pane - (lambda (b e) (set! ok? #t) (send d show #f)) - (lambda (b e) - (fw:preferences:set 'external-browser orig-external) - (send d show #f)))] - [(enable-button) (lambda (_n _v) - (queue-callback - (lambda () - (send ok-button enable (fw:preferences:get 'external-browser)))))]) - (send ok-button enable #f) - (set! callbacks - (cons - (fw:preferences:add-callback 'external-browser enable-button) - callbacks))) - (send d show #t) - (map (lambda (f) (f)) callbacks) - ok?))) + (define title (string-constant choose-browser)) + (define d (make-object dialog% title)) + (define main-pane (make-object vertical-pane% d)) + (define internal-ok? (not url)) + (define ok? #f) + (define orig-external (fw:preferences:get 'external-browser)) + (make-object message% title main-pane) + ;; No need to show the URL (it can be very long) + ;; (when url + ;; (make-object message% (format "URL: ~a" url) main-pane)) + (define-values (panel callbacks) + (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))) + (let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane) + [alignment '(right center)])] + [(ok-button cancel-button) (fw:gui-utils:ok/cancel-buttons + button-pane + (lambda (b e) + (set! ok? #t) + (send d show #f)) + (lambda (b e) + (fw:preferences:set 'external-browser orig-external) + (send d show #f)))] + [(enable-button) + (lambda (_n _v) + (queue-callback + (lambda () (send ok-button enable (fw:preferences:get 'external-browser)))))]) + (send ok-button enable #f) + (set! callbacks (cons (fw:preferences:add-callback 'external-browser enable-button) callbacks))) + (send d show #t) + (map (lambda (f) (f)) callbacks) + ok?) (define panel-installed? #f) (define prefs-panel #f) @@ -140,11 +139,11 @@ (lambda (f) (fw:preferences:add-panel (string-constant browser) (lambda (parent) - (let-values ([(panel cbs) (f parent)]) - (set! prefs-panel panel) - (map (lambda (f) (f panel)) additions) - (set! additions null) - panel))))))) + (define-values (panel cbs) (f parent)) + (set! prefs-panel panel) + (map (lambda (f) (f panel)) additions) + (set! additions null) + panel)))))) (define (add-to-browser-prefs-panel proc) (if prefs-panel @@ -155,150 +154,151 @@ (mk (lambda (parent) (define callbacks null) - (let ([pref-panel (instantiate vertical-panel% () - [parent parent] - [alignment '(left center)])]) - - ;; -------------------- external browser for Unix -------------------- - (when (unix-browser?) - (unless synchronized? - ;; Keep 'external-browser in sync - (fw:preferences:add-callback 'external-browser - (lambda (name browser) - (try-put-preferences (list 'external-browser) (list browser))))) - - (letrec ([v-panel (instantiate group-box-panel% () - (parent pref-panel) - (alignment '(right center)) - (stretchable-height #f) - (label (string-constant external-browser-choice-title)))] - [h-panel (instantiate horizontal-panel% () - (parent v-panel) - (alignment '(center bottom)))] - [none-index (length raw:unix-browser-list)] - [custom-index (add1 none-index)] - [r (instantiate radio-box% () - (label #f) - (choices (append unix-browser-names - (list (string-constant no-browser) - (string-constant browser-command-line-label)))) - (parent h-panel) - (callback - (lambda (radio event) - (let ([n (send radio get-selection)]) - (set-browser! - (cond - [(= n none-index) #f] - [(= n custom-index) (get-custom)] - [else (list-ref raw:unix-browser-list n)]))))))] - [select-custom - (lambda (_ __) - (send r set-selection custom-index) - (set-browser! (get-custom)))] - [get-custom - (lambda () (cons (send pre get-value) (send post get-value)))] - [template-panel (instantiate horizontal-panel% (h-panel) - (spacing 0) - (stretchable-height #f))] - [pre (instantiate text-field% () - (label #f) (parent template-panel) (callback select-custom) - (horiz-margin 0))] - [mess (instantiate message% () (label "") (parent template-panel) - (horiz-margin 0))] - [post (instantiate text-field% () - (label #f) (parent template-panel) (callback select-custom) - (horiz-margin 0))] - [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1) - v-panel))] - [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2) - v-panel))] - [refresh-controls (lambda (pref) - (if (pair? pref) - (begin - (send r set-selection custom-index) - (send pre set-value (car pref)) - (send post set-value (cdr pref))) - (let init ([x raw:unix-browser-list] [n 0]) - (cond - [(null? x) (send r set-selection n)] - [else (if (eq? pref (car x)) - (send r set-selection n) - (init (cdr x) (add1 n)))]))))]) - - (unless ask-later? - (send r enable none-index #f)) - - (refresh-controls (fw:preferences:get 'external-browser)) - (set! callbacks - (cons (fw:preferences:add-callback 'external-browser - (lambda (name browser) (refresh-controls browser))) - callbacks)))) - - ;; -------------------- proxy for doc downloads -------------------- - (when set-help? - (letrec ([p (instantiate group-box-panel% () - [label (string-constant http-proxy)] - [parent pref-panel] - [stretchable-height #f] - [alignment '(left top)])] - [rb (make-object radio-box% - #f (list (string-constant proxy-direct-connection) - (string-constant proxy-use-proxy)) - p - (lambda (r e) - (let ([proxy? (= 1 (send r get-selection))]) - (send proxy-spec enable proxy?) - (if proxy? - (update-proxy) - (fw:preferences:set http-proxy-preference #f)))))] - [proxy-spec (instantiate horizontal-panel% (p) - [stretchable-width #f] - [stretchable-height #f] - [alignment '(left center)])] - [update-proxy (lambda () - (let ([host (send host get-value)] - [port (send port get-value)]) - (let ([ok? (and (regexp-match? #rx"^[-0-9a-zA-Z.]+$" host) - (regexp-match? #rx"^[0-9]+$" port) - (string->number port) - (<= 1 (string->number port) 65535))]) - (when ok? - (fw:preferences:set - http-proxy-preference - (list "http" host (string->number port)))) - (send bad-host show (not ok?)))))] - [host (make-object text-field% - (string-constant proxy-host) - proxy-spec (lambda (x y) (update-proxy)) - "www.someplacethatisaproxy.domain.com")] - [port (make-object text-field% - (string-constant proxy-port) - proxy-spec (lambda (x y) (update-proxy)) "65535")] - [bad-host (make-object message% - (string-constant proxy-bad-host) - p)] - [update-gui - (lambda (proxy-val) - (send bad-host show #f) - (if proxy-val - (begin - (send rb set-selection 1) - (send proxy-spec enable #t) - (unless (string=? (cadr proxy-val) (send host get-value)) - (send host set-value (cadr proxy-val))) - (unless (equal? (caddr proxy-val) (string->number (send port get-value))) - (send port set-value (number->string (caddr proxy-val))))) - (begin - (send rb set-selection 0) - (send proxy-spec enable #f) - (send host set-value "") - (send port set-value ""))))]) - - (fw:preferences:add-callback http-proxy-preference - (lambda (name val) - (update-gui val))) - (update-gui (fw:preferences:get http-proxy-preference)) - (send bad-host show #f))) - - (set! synchronized? #t) - (values pref-panel callbacks))))) + (define pref-panel + (new vertical-panel% [parent parent] [alignment '(left center)])) + + ;; -------------------- external browser for Unix -------------------- + (when (unix-browser?) + (unless synchronized? + ;; Keep 'external-browser in sync + (fw:preferences:add-callback + 'external-browser + (lambda (name browser) (try-put-preferences (list 'external-browser) (list browser))))) + + (letrec + ([v-panel (new group-box-panel% + [parent pref-panel] + [alignment '(right center)] + [stretchable-height #f] + [label (string-constant external-browser-choice-title)])] + [h-panel (new horizontal-panel% [parent v-panel] [alignment '(center bottom)])] + [none-index (length raw:unix-browser-list)] + [custom-index (add1 none-index)] + [r (new radio-box% + [label #f] + [choices + (append unix-browser-names + (list (string-constant no-browser) + (string-constant browser-command-line-label)))] + [parent h-panel] + [callback + (lambda (radio event) + (let ([n (send radio get-selection)]) + (set-browser! (cond + [(= n none-index) #f] + [(= n custom-index) (get-custom)] + [else (list-ref raw:unix-browser-list n)]))))])] + [select-custom (lambda (_ __) + (send r set-selection custom-index) + (set-browser! (get-custom)))] + [get-custom (lambda () (cons (send pre get-value) (send post get-value)))] + [template-panel (instantiate horizontal-panel% (h-panel) + [spacing 0] + [stretchable-height #f])] + [pre (new text-field% + [label #f] + [parent template-panel] + [callback select-custom] + [horiz-margin 0])] + [mess (new message% [label ""] [parent template-panel] [horiz-margin 0])] + [post (new text-field% + [label #f] + [parent template-panel] + [callback select-custom] + [horiz-margin 0])] + [note1 (make-object message% (string-constant browser-cmdline-expl-line-1) v-panel)] + [note2 (make-object message% (string-constant browser-cmdline-expl-line-2) v-panel)] + [refresh-controls (lambda (pref) + (cond + [(pair? pref) + (send r set-selection custom-index) + (send pre set-value (car pref)) + (send post set-value (cdr pref))] + [else + (let init ([x raw:unix-browser-list] + [n 0]) + (cond + [(null? x) (send r set-selection n)] + [else + (if (eq? pref (car x)) + (send r set-selection n) + (init (cdr x) + (add1 n)))]))]))]) + + (unless ask-later? + (send r enable none-index #f)) + + (refresh-controls (fw:preferences:get 'external-browser)) + (set! callbacks + (cons (fw:preferences:add-callback 'external-browser + (lambda (name browser) + (refresh-controls browser))) + callbacks)))) + + ;; -------------------- proxy for doc downloads -------------------- + (when set-help? + (letrec ([p (instantiate group-box-panel% () + [label (string-constant http-proxy)] + [parent pref-panel] + [stretchable-height #f] + [alignment '(left top)])] + [rb (make-object radio-box% + #f + (list (string-constant proxy-direct-connection) + (string-constant proxy-use-proxy)) + p + (lambda (r e) + (let ([proxy? (= 1 (send r get-selection))]) + (send proxy-spec enable proxy?) + (if proxy? + (update-proxy) + (fw:preferences:set http-proxy-preference #f)))))] + [proxy-spec (instantiate horizontal-panel% (p) + [stretchable-width #f] + [stretchable-height #f] + [alignment '(left center)])] + [update-proxy (lambda () + (let ([host (send host get-value)] + [port (send port get-value)]) + (let ([ok? (and (regexp-match? #rx"^[-0-9a-zA-Z.]+$" host) + (regexp-match? #rx"^[0-9]+$" port) + (string->number port) + (<= 1 (string->number port) 65535))]) + (when ok? + (fw:preferences:set http-proxy-preference + (list "http" host (string->number port)))) + (send bad-host show (not ok?)))))] + [host (make-object text-field% + (string-constant proxy-host) + proxy-spec + (lambda (x y) (update-proxy)) + "www.someplacethatisaproxy.domain.com")] + [port (make-object text-field% + (string-constant proxy-port) + proxy-spec + (lambda (x y) (update-proxy)) + "65535")] + [bad-host (make-object message% (string-constant proxy-bad-host) p)] + [update-gui (lambda (proxy-val) + (send bad-host show #f) + (if proxy-val + (begin + (send rb set-selection 1) + (send proxy-spec enable #t) + (unless (string=? (cadr proxy-val) (send host get-value)) + (send host set-value (cadr proxy-val))) + (unless (equal? (caddr proxy-val) + (string->number (send port get-value))) + (send port set-value (number->string (caddr proxy-val))))) + (begin + (send rb set-selection 0) + (send proxy-spec enable #f) + (send host set-value "") + (send port set-value ""))))]) + + (fw:preferences:add-callback http-proxy-preference (lambda (name val) (update-gui val))) + (update-gui (fw:preferences:get http-proxy-preference)) + (send bad-host show #f))) + + (set! synchronized? #t) + (values pref-panel callbacks)))) diff --git a/drracket/gui-debugger/debug-tool.rkt b/drracket/gui-debugger/debug-tool.rkt index cc54b8510..2234dc72b 100644 --- a/drracket/gui-debugger/debug-tool.rkt +++ b/drracket/gui-debugger/debug-tool.rkt @@ -266,10 +266,10 @@ (cond [(not (unbox on-it?)) (values #f #f)] [else - (let ([snip (send editor find-snip pos 'after-or-none)]) - (if (and snip (is-a? snip editor-snip%)) - (loop (send snip get-editor)) - (values pos editor)))])] + (define snip (send editor find-snip pos 'after-or-none)) + (if (and snip (is-a? snip editor-snip%)) + (loop (send snip get-editor)) + (values pos editor))])] [(is-a? editor pasteboard%) (define snip (send editor find-snip x y)) (if (and snip (is-a? snip editor-snip%)) @@ -764,69 +764,69 @@ (run-in-evaluation-thread (lambda () ;(print-struct #t) - (let ([self (current-thread)] - [oeh (uncaught-exception-handler)] - [err-hndlr (error-display-handler)]) - (set! debugged-thread self) - (error-display-handler - (lambda (msg exn) - (err-hndlr msg exn) - (when (and (eq? self (current-thread)) (exn:fail? exn)) - (send (get-tab) suspend - oeh - (continuation-mark-set->list (exn-continuation-marks exn) debug-key) - 'error)))) ; this breaks the buttons because it looks like we can resume - (current-eval - (make-debug-eval-handler - (current-eval) - ; break? -- curried to avoid looking up defs from source each time - (lambda (src) - (let* ([defs (filename->defs src)] - [src-tab (if defs - (send defs get-tab) - (get-tab))] - [breakpoints (if src - (send src-tab get-breakpoints) - breakpoints)] - [single-step? (send tab get-single-step-box)] - [closed? (send src-tab get-closed-box)]) - (lambda (pos) - (and (not (unbox closed?)) - (or (unbox single-step?) - (let ([bp (hash-ref breakpoints pos #f)]) - (if (procedure? bp) - (bp) - bp))))))) - ; break-before - (lambda (top-mark ccm) - (define debug-marks (continuation-mark-set->list ccm debug-key)) - (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)) - ; break-after - (case-lambda - [(top-mark ccm val) - (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) - (car (send (get-tab) suspend - oeh - (cons top-mark debug-marks) - (list 'exit-break val))))] - [(top-mark ccm . vals) - (define debug-marks (continuation-mark-set->list ccm debug-key)) - (apply values - (send (get-tab) suspend - oeh - (cons top-mark debug-marks) - (cons 'exit-break vals)))]))) - (uncaught-exception-handler - (lambda (exn) - (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) - (let ([marks (exn-continuation-marks exn)] - [cont (exn:break-continuation exn)]) - (send (get-tab) suspend - oeh - (continuation-mark-set->list marks debug-key) - 'break) - (cont)) - (oeh exn)))))))))))) + (define self (current-thread)) + (define oeh (uncaught-exception-handler)) + (define err-hndlr (error-display-handler)) + (set! debugged-thread self) + (error-display-handler + (lambda (msg exn) + (err-hndlr msg exn) + (when (and (eq? self (current-thread)) (exn:fail? exn)) + (send (get-tab) suspend + oeh + (continuation-mark-set->list (exn-continuation-marks exn) debug-key) + 'error)))) ; this breaks the buttons because it looks like we can resume + (current-eval + (make-debug-eval-handler + (current-eval) + ; break? -- curried to avoid looking up defs from source each time + (lambda (src) + (let* ([defs (filename->defs src)] + [src-tab (if defs + (send defs get-tab) + (get-tab))] + [breakpoints (if src + (send src-tab get-breakpoints) + breakpoints)] + [single-step? (send tab get-single-step-box)] + [closed? (send src-tab get-closed-box)]) + (lambda (pos) + (and (not (unbox closed?)) + (or (unbox single-step?) + (let ([bp (hash-ref breakpoints pos #f)]) + (if (procedure? bp) + (bp) + bp))))))) + ; break-before + (lambda (top-mark ccm) + (define debug-marks (continuation-mark-set->list ccm debug-key)) + (send (get-tab) suspend oeh (cons top-mark debug-marks) 'entry-break)) + ; break-after + (case-lambda + [(top-mark ccm val) + (let* ([debug-marks (continuation-mark-set->list ccm debug-key)]) + (car (send (get-tab) suspend + oeh + (cons top-mark debug-marks) + (list 'exit-break val))))] + [(top-mark ccm . vals) + (define debug-marks (continuation-mark-set->list ccm debug-key)) + (apply values + (send (get-tab) suspend + oeh + (cons top-mark debug-marks) + (cons 'exit-break vals)))]))) + (uncaught-exception-handler + (lambda (exn) + (if (and (exn:break? exn) (send (get-tab) suspend-on-break?)) + (let ([marks (exn-continuation-marks exn)] + [cont (exn:break-continuation exn)]) + (send (get-tab) suspend + oeh + (continuation-mark-set->list marks debug-key) + 'break) + (cont)) + (oeh exn))))))))))) (define (debug-tab-mixin super%) (class super% @@ -1038,34 +1038,35 @@ (send (get-frame) register-stack-frames frames already-stopped?) (send (get-frame) register-vars (list-ref frames (get-frame-num)))) (send status-message set-label - (if (and (cons? status) top-of-stack?) - (let ([expr (mark-source (first frames))]) - (cond - ; should succeed unless the user closes a secondary tab during debugging - [(filename->defs (syntax-source expr)) - => (lambda (defs) - (clean-status - (string-append - (if (syntax-position expr) - (trim-expr-str - (send defs get-text - (sub1 (syntax-position expr)) - (+ -1 (syntax-position expr) (syntax-span expr)))) - "??") - " => " - (if (= 2 (length status)) - (or (render (cadr status)) "??") - (string-append - "(values" - (let loop ([vals (rest status)]) - (cond - [(cons? vals) (string-append " " - (or (render (first vals)) - "??") - (loop (rest vals)))] - [else ")"])))))))] - [""])) - "")) + (cond + [(and (cons? status) top-of-stack?) + (define expr (mark-source (first frames))) + (cond + ; should succeed unless the user closes a secondary tab during debugging + [(filename->defs (syntax-source expr)) + => + (lambda (defs) + (clean-status + (string-append + (if (syntax-position expr) + (trim-expr-str + (send defs get-text + (sub1 (syntax-position expr)) + (+ -1 (syntax-position expr) (syntax-span expr)))) + "??") + " => " + (if (= 2 (length status)) + (or (render (cadr status)) "??") + (string-append "(values" + (let loop ([vals (rest status)]) + (cond + [(cons? vals) + (string-append " " + (or (render (first vals)) "??") + (loop (rest vals)))] + [else ")"])))))))] + [""])] + [else ""])) (cond [(get-current-frame-endpoints) => (lambda (start/end) (cond [(and (first start/end) (defs-containing-current-frame)) @@ -1198,13 +1199,12 @@ [else (already-debugging tab)])) (define/override (execute-callback) - (let ([tab (get-current-tab)]) - (cond - [(eq? tab (send tab get-primary)) - (send (get-current-tab) prepare-execution debug?) - (super execute-callback)] - [else - (already-debugging tab)]))) + (define tab (get-current-tab)) + (cond + [(eq? tab (send tab get-primary)) + (send (get-current-tab) prepare-execution debug?) + (super execute-callback)] + [else (already-debugging tab)])) (define/private (already-debugging tab) (message-box diff --git a/drracket/setup/plt-installer-unit.rkt b/drracket/setup/plt-installer-unit.rkt index a31eee5f8..aba9b2ca9 100644 --- a/drracket/setup/plt-installer-unit.rkt +++ b/drracket/setup/plt-installer-unit.rkt @@ -41,12 +41,10 @@ (sleep 0.2) ; kludge to allow f to appear first (end-busy-cursor) ;; do these strings ever appear? (should move to string-constants, if so) - (let ([d (get-directory - "Select the destination for unpacking" - frame)]) - (unless d - (printf ">>> Cancelled <<<\n")) - (begin-busy-cursor) - d)) + (define d (get-directory "Select the destination for unpacking" frame)) + (unless d + (printf ">>> Cancelled <<<\n")) + (begin-busy-cursor) + d) #:show-beginning-of-file? #t)) cleanup-thunk)))