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

adjust the package installation menu item in drracket to use mrlib/terminal

Browse Source
This commit is contained in:
Robby Findler 2013-04-04 10:19:35 -05:00
parent 94861becd0
commit 8246d073c0
2 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,6 +23,8 @@
(define sc-install-pkg-force? (string-constant install-pkg-force?))
(define sc-install-pkg-command-line (string-constant install-pkg-command-line))
(preferences:set-default 'drracket:gui-installer-pkg-source "" string?)
(define (install-pkg parent)
(define dlg (new dialog%
[parent parent]
@ -32,7 +34,10 @@
[parent dlg]
[min-width 600]
[label sc-install-pkg-source-label]
[callback (λ (_1 _2) (adjust-all))]))
[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%
@ -213,6 +218,7 @@
setup/plt-installer
help/bug-report
setup/unpack
mrlib/terminal
pkg
(submod "." install-pkg))
(provide frame@)
@ -385,16 +391,10 @@
(λ (item evt)
(define res (install-pkg this))
(when res
(with-handlers ((exn:fail?
(λ (x)
(define sp (open-output-string))
(parameterize ([current-error-port sp])
(drracket:init:original-error-display-handler
(exn-message x)
x))
(message-box (string-constant install-pkg-error-installing-title)
(get-output-string sp)))))
(apply install res))))])
(parameterize ([error-display-handler drracket:init:original-error-display-handler])
(in-terminal
#:title (string-constant install-pkg-dialog-title)
(λ (cust parent) (apply install res))))))])
(super file-menu:between-open-and-revert file-menu))
(define/override (file-menu:between-print-and-close menu)

22
collects/mrlib/terminal.rkt
View File

@ -22,7 +22,7 @@
;; runs the installer in a separate thread and returns immediately,
;; before the installation is complete. The cleanup thunk is called when installation completes
(define (in-terminal do-install
#:title [title "mrlib/terminal"]
#:title [title "mrlib/terminal"]
#:abort-label [abort-label (string-constant plt-installer-abort-installation)]
#:aborted-message [aborted-message (string-constant plt-installer-aborted)]
#:cleanup-thunk [cleanup-thunk void])
@ -104,7 +104,7 @@
void))
(define plain-style (send (editor:get-standard-style-list) find-named-style "Standard"))
(define red-delta (make-object style-delta%))
(define red-delta (make-object style-delta% 'change-italic))
(send red-delta set-delta-foreground "red")
(define error-style (send (editor:get-standard-style-list) find-or-create-style
plain-style
@ -138,14 +138,16 @@
(lambda ()
(cleanup-thunk)))))))))
(parameterize ([current-output-port output-port]
[current-error-port error-port]
[exit-handler
(λ (x)
(unless (equal? x 0)
(eprintf "exited with code: ~s\n" x))
(custodian-shutdown-all installer-cust))])
(do-install inst-eventspace dlg))
(let/ec k
(parameterize ([current-output-port output-port]
[current-error-port error-port]
[error-escape-handler (λ () (k (void)))]
[exit-handler
(λ (x)
(unless (equal? x 0)
(eprintf "exited with code: ~s\n" x))
(custodian-shutdown-all installer-cust))])
(do-install inst-eventspace dlg)))
(parameterize ([current-eventspace orig-eventspace])
(queue-callback
(lambda ()