refactor the plt installation code in drracket to pull out
the GUI wrapper around command-line like utilities
This commit is contained in:
Robby Findler
parent
15abd8f9dd
commit
ecf2b16bf0
|
|
@ -21,6 +21,7 @@
|
|||
@include-section["image-core.scrbl"]
|
||||
@include-section["matrix-snip.scrbl"]
|
||||
@include-section["tex-table.scrbl"]
|
||||
@include-section["terminal.scrbl"]
|
||||
|
||||
@section{Acknowledgments}
|
||||
|
||||
|
|
|
|||
45
collects/mrlib/scribblings/terminal.scrbl
Normal file
45
collects/mrlib/scribblings/terminal.scrbl
Normal 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
157
collects/mrlib/terminal.rkt
Normal 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)))))))))
|
||||
|
|
@ -25,7 +25,8 @@
|
|||
launcher/launcher-sig
|
||||
dynext/file-sig
|
||||
racket/gui/base
|
||||
racket/future))
|
||||
racket/future
|
||||
mrlib/terminal))
|
||||
|
||||
@(define-syntax-rule (local-module mod . body)
|
||||
(begin
|
||||
|
|
@ -717,18 +718,22 @@ v
|
|||
A thunk that is run after a @filepath{.plt} file is installed.}
|
||||
|
||||
@defproc[(with-installer-window
|
||||
(do-install ((or/c (is-a?/c dialog%) (is-a?/c frame%))
|
||||
. -> . void?))
|
||||
(cleanup-thunk (-> any)))
|
||||
[do-install (-> (or/c (is-a?/c dialog%) (is-a?/c frame%))
|
||||
void?)]
|
||||
[cleanup-thunk (-> any)])
|
||||
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;
|
||||
@racket[cleanup-thunk] is called on a queued callback to the
|
||||
eventspace active when @racket[with-installer-window] is
|
||||
invoked.}
|
||||
Equivalent to
|
||||
@racketblock[(define installer-run (on-installer-run))
|
||||
(parameterize ([on-terminal-run
|
||||
(λ ()
|
||||
(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?)
|
||||
(get-dir-proc (-> (or/c path-string? false/c))))
|
||||
|
|
|
|||
|
|
@ -1,132 +1,51 @@
|
|||
(module plt-installer-unit mzscheme
|
||||
(require mzlib/unit
|
||||
mred/mred-sig
|
||||
mzlib/class
|
||||
mzlib/etc
|
||||
"plt-installer-sig.rkt"
|
||||
(prefix single: "plt-single-installer.rkt")
|
||||
string-constants)
|
||||
#lang racket/base
|
||||
(require racket/unit
|
||||
mred/mred-sig
|
||||
racket/class
|
||||
"plt-installer-sig.rkt"
|
||||
(prefix-in single: "plt-single-installer.rkt")
|
||||
(prefix-in mrlib/terminal: mrlib/terminal)
|
||||
string-constants)
|
||||
|
||||
(provide plt-installer@)
|
||||
(define-unit plt-installer@
|
||||
(import mred^)
|
||||
(export setup:plt-installer^)
|
||||
|
||||
(define on-installer-run
|
||||
(make-parameter void))
|
||||
|
||||
;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> 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 (with-installer-window do-install cleanup-thunk)
|
||||
(let ([orig-eventspace (current-eventspace)]
|
||||
[orig-custodian (current-custodian)]
|
||||
[inst-eventspace (make-eventspace)])
|
||||
(parameterize ([current-eventspace inst-eventspace])
|
||||
(letrec ([dlg (make-object (class dialog% ()
|
||||
(define/augment can-close? (lambda () (send done is-enabled?)))
|
||||
(define/augment on-close (lambda () (done-callback)))
|
||||
(super-make-object
|
||||
(string-constant plt-installer-progress-window-title)
|
||||
#f 600 300 #f #f '(resize-border))))]
|
||||
[text (make-object text%)]
|
||||
[canvas (make-object editor-canvas% dlg text)]
|
||||
[button-panel (instantiate horizontal-panel% ()
|
||||
(parent dlg)
|
||||
(stretchable-height #f)
|
||||
(alignment '(center center)))]
|
||||
[kill-button (make-object button%
|
||||
(string-constant plt-installer-abort-installation)
|
||||
button-panel
|
||||
(lambda (b e) (kill)))]
|
||||
[done (make-object button% (string-constant close) button-panel (lambda (b e) (done-callback)))]
|
||||
[output (make-output-port
|
||||
#f
|
||||
always-evt
|
||||
(lambda (bytes start end flush? enable-break?)
|
||||
(parameterize ([current-eventspace inst-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(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)))))
|
||||
(provide plt-installer@)
|
||||
(define-unit plt-installer@
|
||||
(import mred^)
|
||||
(export setup:plt-installer^)
|
||||
|
||||
(define on-installer-run (make-parameter void))
|
||||
|
||||
;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> 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 (with-installer-window do-install cleanup-thunk)
|
||||
(define installer-run (on-installer-run))
|
||||
(parameterize ([on-terminal-run
|
||||
(λ ()
|
||||
(printf "\nInstallation complete.\n")
|
||||
(installer-run))])
|
||||
(mrlib/terminal:in-terminal
|
||||
(λ (custodian frame) (do-install frame))
|
||||
#:title (string-constant plt-installer-progress-window-title)
|
||||
#:cleanup-thunk cleanup-thunk)))
|
||||
|
||||
(define run-single-installer single:run-single-installer)
|
||||
|
||||
(define (run-installer 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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user