From cc4aee8e82d238a14252d678d4aa891aea32f340 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Apr 2013 15:21:59 -0600 Subject: [PATCH] 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 --- collects/mrlib/scribblings/terminal.scrbl | 79 ++++++++++--- collects/mrlib/terminal.rkt | 130 +++++++++++++++------- 2 files changed, 151 insertions(+), 58 deletions(-) diff --git a/collects/mrlib/scribblings/terminal.scrbl b/collects/mrlib/scribblings/terminal.scrbl index e9929c18..e4c98767 100644 --- a/collects/mrlib/scribblings/terminal.scrbl +++ b/collects/mrlib/scribblings/terminal.scrbl @@ -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]. -} \ No newline at end of file +} + +@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.} +} diff --git a/collects/mrlib/terminal.rkt b/collects/mrlib/terminal.rkt index dfe37271..94a94bfe 100644 --- a/collects/mrlib/terminal.rkt +++ b/collects/mrlib/terminal.rkt @@ -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)))))))