mrlib/terminal: generalize to allow an embedded terminal
That is, instead of always creating a new frame, allow the terminal GUI to work as a panel. original commit: b7f17b389a9b963defc1befc199a7f38f8d34014
This commit is contained in:
Matthew Flatt
parent
47297a882e
commit
cc4aee8e82
|
|
@ -8,33 +8,49 @@
|
|||
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?)]
|
||||
@defproc[(in-terminal [doit (-> eventspace?
|
||||
(or/c (is-a?/c top-level-window<%>) #f)
|
||||
void?)]
|
||||
[#:container container (or/c #f (is-a?/c area-container<%>)) #f]
|
||||
[#: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?]{
|
||||
(is-a?/c terminal<%>)]{
|
||||
|
||||
Creates a dialog, sets up the current error and output ports to
|
||||
print into the dialog's contents
|
||||
Creates a GUI, sets up the current error and output ports to
|
||||
print into the GUI's content,
|
||||
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 GUI is created in a new @racket[frame%], unless
|
||||
@racket[container] is not @racket[#f], in which case the GUI is
|
||||
created as a new panel inside @racket[container]. If a frame is
|
||||
created, it is provided as the second argument to @racket[doit],
|
||||
otherwise the second argument to @racket[doit] is @racket[#f].
|
||||
If a frame is created, its title is @racket[title].
|
||||
|
||||
The result of @racket[in-terminal] is a @racket[terminal<%>] object
|
||||
that reports on the state of the terminal; this result is produced
|
||||
just after @racket[doit] is started.
|
||||
|
||||
The @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).
|
||||
In addition to the I/O generated by @racket[doit], the generated GUI
|
||||
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).
|
||||
|
||||
If @racket[container] is @racket[#f], then the close button closes
|
||||
the frame; otherwise, the close button causes the container created
|
||||
for the terminal's GUI to be removed from its parent.
|
||||
|
||||
The value of @racket[on-terminal-run] is invoked after @racket[doit]
|
||||
returns, but not if it is aborted or an exception is raised.
|
||||
|
|
@ -42,4 +58,31 @@ in command-line scripts.}
|
|||
|
||||
@defparam[on-terminal-run run (-> void?)]{
|
||||
Invoked by @racket[in-terminal].
|
||||
}
|
||||
}
|
||||
|
||||
@definterface[terminal<%> ()]{
|
||||
|
||||
The interface of a terminal status and control object produced by
|
||||
@racket[in-terminal].
|
||||
|
||||
@defmethod[(is-closed?) boolean?]{
|
||||
|
||||
Returns @racket[#t] if the terminal GUI has been closed, @racket[#f]
|
||||
otherwise.}
|
||||
|
||||
@defmethod[(close) void?]{
|
||||
|
||||
Closes the terminal GUI. Call this method only if @method[terminal<%>
|
||||
can-close?] returns @racket[#t].}
|
||||
|
||||
@defmethod[(can-close?) boolean?]{
|
||||
|
||||
Reports whether the terminal GUI can be closed, because the terminal
|
||||
process is complete (or, equivalently, whether the close button is
|
||||
enabled).}
|
||||
|
||||
@defmethod[(can-close-evt) evt?]{
|
||||
|
||||
Returns a synchronizable event that becomes ready for synchronization
|
||||
when the terminal GUI can be closed.}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -8,12 +8,21 @@
|
|||
(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?)]))
|
||||
[in-terminal (->* ((-> eventspace? (or/c #f (is-a?/c top-level-window<%>)) void?))
|
||||
(#:container (is-a?/c area-container<%>)
|
||||
#:title string?
|
||||
#:abort-label string?
|
||||
#:aborted-message string?
|
||||
#:cleanup-thunk (-> void?))
|
||||
(is-a?/c terminal<%>))])
|
||||
terminal<%>)
|
||||
|
||||
(define terminal<%>
|
||||
(interface ()
|
||||
is-closed?
|
||||
close
|
||||
can-close?
|
||||
can-close-evt))
|
||||
|
||||
(define on-terminal-run (make-parameter void))
|
||||
|
||||
|
|
@ -22,6 +31,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
|
||||
#:container [container #f]
|
||||
#:title [title "mrlib/terminal"]
|
||||
#:abort-label [abort-label (string-constant plt-installer-abort-installation)]
|
||||
#:aborted-message [aborted-message (string-constant plt-installer-aborted)]
|
||||
|
|
@ -33,52 +43,72 @@
|
|||
(define on-terminal-run-proc (on-terminal-run))
|
||||
|
||||
(define frame #f)
|
||||
(define sub-container #f)
|
||||
(define text #f)
|
||||
(define close-button #f)
|
||||
(define kill-button #f)
|
||||
(define setup-sema (make-semaphore 0))
|
||||
(define can-close-sema (make-semaphore))
|
||||
|
||||
(define (close)
|
||||
(if frame
|
||||
(send frame show #f)
|
||||
(send container delete-child sub-container))
|
||||
(close-callback))
|
||||
(define (close-callback)
|
||||
(custodian-shutdown-all installer-cust))
|
||||
|
||||
(parameterize ([current-eventspace inst-eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(set! frame (new (class frame%
|
||||
(define/augment (can-close?) (send close-button is-enabled?))
|
||||
(define/augment (on-close) (close-callback))
|
||||
(super-new [label title]
|
||||
[width 600]
|
||||
[height 300]))))
|
||||
(define mb (new menu-bar% [parent frame]))
|
||||
(define edit-menu (new menu%
|
||||
[label (string-constant edit-menu)]
|
||||
[parent mb]))
|
||||
(define copy-menu-item
|
||||
(new menu-item%
|
||||
[parent edit-menu]
|
||||
[label (string-constant copy-menu-item)]
|
||||
[shortcut #\c]
|
||||
[demand-callback
|
||||
(λ (item)
|
||||
(send copy-menu-item enable
|
||||
(not (= (send text get-start-position)
|
||||
(send text get-end-position)))))]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(send text copy))]))
|
||||
(define select-all-item
|
||||
(unless container
|
||||
(set! frame
|
||||
(new (class frame%
|
||||
(define/augment (can-close?) (send close-button is-enabled?))
|
||||
(define/augment (on-close) (close-callback))
|
||||
(super-new [label title]
|
||||
[width 600]
|
||||
[height 300]))))
|
||||
(set! container frame)
|
||||
(define mb (new menu-bar% [parent frame]))
|
||||
(define edit-menu (new menu%
|
||||
[label (string-constant edit-menu)]
|
||||
[parent mb]))
|
||||
(define copy-menu-item
|
||||
(new menu-item%
|
||||
[parent edit-menu]
|
||||
[label (string-constant copy-menu-item)]
|
||||
[shortcut #\c]
|
||||
[demand-callback
|
||||
(λ (item)
|
||||
(send copy-menu-item enable
|
||||
(not (= (send text get-start-position)
|
||||
(send text get-end-position)))))]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(send text copy))]))
|
||||
(new menu-item%
|
||||
[parent edit-menu]
|
||||
[label (string-constant select-all-menu-item)]
|
||||
[shortcut #\a]
|
||||
[callback
|
||||
(λ (item evt)
|
||||
(send text set-position 0 (send text last-position)))]))
|
||||
(send text set-position 0 (send text last-position)))]))
|
||||
|
||||
(set! sub-container
|
||||
(or frame
|
||||
(new (class vertical-panel%
|
||||
(super-new)
|
||||
(define/override (on-superwindow-show on?)
|
||||
(unless on? (close-callback))))
|
||||
[parent container])))
|
||||
|
||||
(set! text (new (text:hide-caret/selection-mixin text:standard-style-list%)))
|
||||
(define canvas (new editor-canvas%
|
||||
[parent frame]
|
||||
[parent sub-container]
|
||||
[editor text]))
|
||||
(define button-panel (new horizontal-panel%
|
||||
[parent frame]
|
||||
[parent sub-container]
|
||||
[stretchable-height #f]
|
||||
[alignment '(center center)]))
|
||||
(set! kill-button (new button%
|
||||
|
|
@ -88,13 +118,17 @@
|
|||
(set! close-button (new button%
|
||||
[label (string-constant close)]
|
||||
[parent button-panel]
|
||||
[callback (λ (b e) (close-callback))]))
|
||||
[callback (λ (b e) (close))]))
|
||||
|
||||
(define (close)
|
||||
(if frame
|
||||
(send frame show #f)
|
||||
(send container delete-child sub-container))
|
||||
(close-callback))
|
||||
|
||||
(define (kill-callback)
|
||||
(custodian-shutdown-all installer-cust)
|
||||
(fprintf output-port "\n~a\n" aborted-message))
|
||||
(define (close-callback)
|
||||
(send frame 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))
|
||||
|
|
@ -102,7 +136,8 @@
|
|||
(send text lock #t)
|
||||
(send text hide-caret #t)
|
||||
(semaphore-post setup-sema)
|
||||
(send frame show #t))))
|
||||
(when frame
|
||||
(send frame show #t)))))
|
||||
|
||||
(semaphore-wait setup-sema)
|
||||
|
||||
|
|
@ -158,7 +193,8 @@
|
|||
(queue-callback
|
||||
(λ ()
|
||||
(send kill-button enable #f)
|
||||
(send close-button enable #t))))
|
||||
(send close-button enable #t)
|
||||
(semaphore-post can-close-sema))))
|
||||
(unless completed-successfully?
|
||||
(parameterize ([current-eventspace orig-eventspace])
|
||||
(queue-callback
|
||||
|
|
@ -183,4 +219,18 @@
|
|||
[current-error-port error-port])
|
||||
(on-terminal-run-proc))
|
||||
(cleanup-thunk)
|
||||
(custodian-shutdown-all installer-cust)))))))))
|
||||
(custodian-shutdown-all installer-cust))))))))
|
||||
|
||||
(new (class* object% (terminal<%>)
|
||||
(super-new)
|
||||
(define/public (can-close-evt)
|
||||
(semaphore-peek-evt can-close-sema))
|
||||
(define/public (is-closed?)
|
||||
(not (send sub-container is-shown?)))
|
||||
(define/public (can-close?)
|
||||
(send close-button is-enabled?))
|
||||
(define/public (close)
|
||||
(unless (is-closed?)
|
||||
(if frame
|
||||
(send frame show #f)
|
||||
(send container delete-child sub-container)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user