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

refactor the plt installation code in drracket to pull out

Browse Source 
the GUI wrapper around command-line like utilities
This commit is contained in:
Robby Findler 2013-04-03 22:22:45 -05:00
parent 15abd8f9dd
commit ecf2b16bf0
5 changed files with 269 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mrlib/scribblings/mrlib.scrbl
View File

@ -21,6 +21,7 @@
@include-section["image-core.scrbl"] @include-section["image-core.scrbl"]
@include-section["matrix-snip.scrbl"] @include-section["matrix-snip.scrbl"]
@include-section["tex-table.scrbl"] @include-section["tex-table.scrbl"]
@include-section["terminal.scrbl"]
@section{Acknowledgments} @section{Acknowledgments}

45
collects/mrlib/scribblings/terminal.scrbl Normal file
View File

@ -0,0 +1,45 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mrlib/terminal string-constants))
@title{Terminal Window}
@defmodule[mrlib/terminal]{The @racketmodname[mrlib/terminal] library provides
a simple GUI wrapper around functions that normally would run
in command-line scripts.}
@defproc[(in-terminal [doit (-> eventspace? (is-a?/c top-level-window<%>) void?)]
[#:cleanup-thunk cleanup-thunk (-> void?) void]
[#:title title string? "mrlib/terminal"]
[#:abort-label abort-label string? (string-constant plt-installer-abort-installation)]
[#:aborted-message aborted-message string? (string-constant plt-installer-aborted)])
void?]{
Creates a dialog, sets up the current error and output ports to
print into the dialog's contents
and calls @racket[doit] in a separate thread under a separate
custodian. The @racket[exit-handler] is set to a function that
shuts down the new custodian.
Returns before @racket[doit] is complete (unless @racket[doit]
completes quickly);
@racket[cleanup-thunk] is called on a queued callback to the
eventspace active when @racket[with-installer-window] is
invoked after @racket[doit] completes.
The @racket[title] is the dialog of the dialog. In addition to the IO
generated by @racket[doit], the dialog also contains two buttons,
the abort button (with label @racket[abort-label]) and the close
button (with label @racket[(string-constant close)]). When the
abort button is pushed, the newly created custodian is shut down and
the @racket[aborted-message] is printed in the dialog. The close
button becomes active when @racket[doit] returns or when the thread
running it is killed (via a custodian shut down, typically).
The value of @racket[on-terminal-run] is invoked after @racket[doit]
returns, but not if it is aborted or an exception is raised.
}
@defparam[on-terminal-run run (-> void?)]{
Invoked by @racket[in-terminal].
}

157
collects/mrlib/terminal.rkt Normal file
View File

@ -0,0 +1,157 @@
#lang racket/base
(require racket/gui/base
racket/class
racket/contract
framework
string-constants)
(provide
(contract-out
[on-terminal-run (parameter/c (-> void?))]
[in-terminal (->* ((-> eventspace? (is-a?/c top-level-window<%>) void?))
(#:title string?
#:abort-label string?
#:aborted-message string?
#:cleanup-thunk (-> void?))
void?)]))
(define on-terminal-run (make-parameter void))
;; creates a frame and sets up the current error and output ports
;; before calling `do-install'.
;; 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"]
#:abort-label [abort-label (string-constant plt-installer-abort-installation)]
#:aborted-message [aborted-message (string-constant plt-installer-aborted)]
#:cleanup-thunk [cleanup-thunk void])
(define orig-eventspace (current-eventspace))
(define orig-custodian (current-custodian))
(define inst-eventspace (make-eventspace))
(define on-terminal-run-proc (on-terminal-run))
(define dlg #f)
(define text #f)
(define close-button #f)
(define kill-button #f)
(define setup-sema (make-semaphore 0))
(parameterize ([current-eventspace inst-eventspace])
(queue-callback
(λ ()
(set! dlg (new (class dialog%
(define/augment (can-close?) (send close-button is-enabled?))
(define/augment (on-close) (close-callback))
(super-new [label title]
[width 600]
[height 300]
[style '(resize-border)]))))
(set! text (new (text:hide-caret/selection-mixin text:standard-style-list%)))
(define canvas (new editor-canvas% [parent dlg] [editor text]))
(define button-panel (new horizontal-panel%
(parent dlg)
(stretchable-height #f)
(alignment '(center center))))
(set! kill-button (new button%
[label abort-label]
[parent button-panel]
[callback (λ (b e) (kill-callback))]))
(set! close-button (new button%
[label (string-constant close)]
[parent button-panel]
[callback (λ (b e) (close-callback))]))
(define (kill-callback)
(custodian-shutdown-all installer-cust)
(fprintf output-port "\n~a\n" aborted-message))
(define (close-callback)
(send dlg show #f)
(custodian-shutdown-all installer-cust))
(send close-button enable #f)
(send canvas allow-tab-exit #t)
((current-text-keymap-initializer) (send text get-keymap))
(send text set-styles-sticky #f)
(send text lock #t)
(send text hide-caret #t)
(semaphore-post setup-sema)
(send dlg show-without-yield))))
(semaphore-wait setup-sema)
(define (mk-port style)
(make-output-port
#f
always-evt
(lambda (bytes start end flush? enable-break?)
(define str (bytes->string/utf-8 (subbytes bytes start end)))
(parameterize ([current-eventspace inst-eventspace])
(queue-callback
(lambda ()
(define lp (send text last-position))
(send text begin-edit-sequence)
(send text lock #f)
(send text insert
str
(send text last-position)
'same
; Scroll on newlines only:
(regexp-match? #rx"\n" str))
(send text change-style style lp (send text last-position))
(send text lock #t)
(send text end-edit-sequence))))
(- end start))
void))
(define plain-style (send (editor:get-standard-style-list) find-named-style "Standard"))
(define red-delta (make-object style-delta%))
(send red-delta set-delta-foreground "red")
(define error-style (send (editor:get-standard-style-list) find-or-create-style
plain-style
red-delta))
(define output-port (mk-port plain-style))
(define error-port (mk-port error-style))
(define completed-successfully? #f)
(define installer-cust (make-custodian))
(parameterize ([current-custodian installer-cust])
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(let ([installer-thread (current-thread)])
(parameterize ([current-custodian orig-custodian])
(thread
(lambda ()
(thread-wait installer-thread)
(parameterize ([current-eventspace inst-eventspace])
(queue-callback
(λ ()
(send kill-button enable #f)
(send close-button enable #t))))
(unless completed-successfully?
(parameterize ([current-eventspace orig-eventspace])
(queue-callback
(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))
(parameterize ([current-eventspace orig-eventspace])
(queue-callback
(lambda ()
(set! completed-successfully? #t)
(parameterize ([current-output-port output-port]
[current-error-port error-port])
(on-terminal-run-proc))
(cleanup-thunk)
(custodian-shutdown-all installer-cust)))))))))

27
collects/scribblings/raco/setup.scrbl
View File

@ -25,7 +25,8 @@
launcher/launcher-sig launcher/launcher-sig
dynext/file-sig dynext/file-sig
racket/gui/base racket/gui/base
racket/future)) racket/future
mrlib/terminal))
@(define-syntax-rule (local-module mod . body) @(define-syntax-rule (local-module mod . body)
(begin (begin
@ -717,18 +718,22 @@ v
A thunk that is run after a @filepath{.plt} file is installed.} A thunk that is run after a @filepath{.plt} file is installed.}
@defproc[(with-installer-window @defproc[(with-installer-window
(do-install ((or/c (is-a?/c dialog%) (is-a?/c frame%)) [do-install (-> (or/c (is-a?/c dialog%) (is-a?/c frame%))
. -> . void?)) void?)]
(cleanup-thunk (-> any))) [cleanup-thunk (-> any)])
void?]{ void?]{
Creates a frame, sets up the current error and output ports, and
turns on the busy cursor before calling @racket[do-install] in a separate
thread.
Returns before the installation process is complete; Equivalent to
@racket[cleanup-thunk] is called on a queued callback to the @racketblock[(define installer-run (on-installer-run))
eventspace active when @racket[with-installer-window] is (parameterize ([on-terminal-run
invoked.} (λ ()
(printf "\nInstallation complete.\n")
(installer-run))])
(in-terminal
(λ (custodian tlw) (do-install tlw))
#:title (string-constant plt-installer-progress-window-title)
#:cleanup-thunk cleanup-thunk))]
}
@defproc[(run-single-installer (file path-string?) @defproc[(run-single-installer (file path-string?)
(get-dir-proc (-> (or/c path-string? false/c)))) (get-dir-proc (-> (or/c path-string? false/c))))

181
collects/setup/plt-installer-unit.rkt
View File

@ -1,132 +1,51 @@
(module plt-installer-unit mzscheme #lang racket/base
(require mzlib/unit (require racket/unit
mred/mred-sig mred/mred-sig
mzlib/class racket/class
mzlib/etc "plt-installer-sig.rkt"
"plt-installer-sig.rkt" (prefix-in single: "plt-single-installer.rkt")
(prefix single: "plt-single-installer.rkt") (prefix-in mrlib/terminal: mrlib/terminal)
string-constants) string-constants)
(provide plt-installer@) (provide plt-installer@)
(define-unit plt-installer@ (define-unit plt-installer@
(import mred^) (import mred^)
(export setup:plt-installer^) (export setup:plt-installer^)
(define on-installer-run (define on-installer-run (make-parameter void))
(make-parameter void))
;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> void
;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> void ;; creates a frame and sets up the current error and output ports
;; creates a frame and sets up the current error and output ports ;; before calling `do-install'.
;; before calling `do-install'. ;; runs the installer in a separate thread and returns immediately,
;; runs the installer in a separate thread and returns immediately, ;; before the installation is complete. The cleanup thunk is called when installation completes
;; before the installation is complete. The cleanup thunk is called when installation completes (define (with-installer-window do-install cleanup-thunk)
(define (with-installer-window do-install cleanup-thunk) (define installer-run (on-installer-run))
(let ([orig-eventspace (current-eventspace)] (parameterize ([on-terminal-run
[orig-custodian (current-custodian)] (λ ()
[inst-eventspace (make-eventspace)]) (printf "\nInstallation complete.\n")
(parameterize ([current-eventspace inst-eventspace]) (installer-run))])
(letrec ([dlg (make-object (class dialog% () (mrlib/terminal:in-terminal
(define/augment can-close? (lambda () (send done is-enabled?))) (λ (custodian frame) (do-install frame))
(define/augment on-close (lambda () (done-callback))) #:title (string-constant plt-installer-progress-window-title)
(super-make-object #:cleanup-thunk cleanup-thunk)))
(string-constant plt-installer-progress-window-title)
#f 600 300 #f #f '(resize-border))))] (define run-single-installer single:run-single-installer)
[text (make-object text%)]
[canvas (make-object editor-canvas% dlg text)] (define (run-installer file [cleanup-thunk void])
[button-panel (instantiate horizontal-panel% () (with-installer-window
(parent dlg) (lambda (frame)
(stretchable-height #f) (run-single-installer
(alignment '(center center)))] file
[kill-button (make-object button% (lambda ()
(string-constant plt-installer-abort-installation) (sleep 0.2) ; kludge to allow f to appear first
button-panel (end-busy-cursor)
(lambda (b e) (kill)))] ;; do these strings ever appear? (should move to string-constants, if so)
[done (make-object button% (string-constant close) button-panel (lambda (b e) (done-callback)))] (let ([d (get-directory
[output (make-output-port "Select the destination for unpacking"
#f frame)])
always-evt (unless d
(lambda (bytes start end flush? enable-break?) (printf ">>> Cancelled <<<\n"))
(parameterize ([current-eventspace inst-eventspace]) (begin-busy-cursor)
(queue-callback d))))
(lambda () cleanup-thunk)))
(let ([str (bytes->string/utf-8 (subbytes bytes start end))])
(send text lock #f)
(send text insert
str
(send text last-position)
'same
; Scroll on newlines only:
(regexp-match #rx"\n" str))
(send text lock #t)))))
(- end start))
void)]
[kill
(lambda ()
(custodian-shutdown-all installer-cust)
(fprintf output "\n~a\n" (string-constant plt-installer-aborted))
(send done enable #t))]
[completed-successfully? #f]
[done-callback
(lambda ()
(send dlg show #f)
(custodian-shutdown-all installer-cust))]
[installer-cust (make-custodian)])
(send done enable #f)
(send canvas allow-tab-exit #t)
((current-text-keymap-initializer) (send text get-keymap))
(send text lock #t)
;; still do this even tho we aren't in the eventspace main thread
(thread (lambda () (send dlg show #t)))
(parameterize ([current-custodian installer-cust])
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(let ([installer-thread (current-thread)])
(parameterize ([current-custodian orig-custodian])
(thread
(lambda ()
(thread-wait installer-thread)
(send kill-button enable #f)
(unless completed-successfully?
(parameterize ([current-eventspace orig-eventspace])
(queue-callback
(lambda ()
(cleanup-thunk)))))))))
(parameterize ([current-output-port output]
[current-error-port output])
(do-install dlg))
(parameterize ([current-eventspace orig-eventspace])
(queue-callback
(lambda ()
(fprintf output "\nInstallation complete.\n")
(set! completed-successfully? #t)
((on-installer-run))
(cleanup-thunk)
(custodian-shutdown-all installer-cust))))
(send done enable #t)))))))))
(define run-single-installer single:run-single-installer)
(define run-installer
(opt-lambda (file [cleanup-thunk void])
(with-installer-window
(lambda (frame)
(run-single-installer
file
(lambda ()
(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))))
cleanup-thunk)))))