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

mrlib/terminal: add options

Browse Source
This commit is contained in:
Matthew Flatt 2013-08-21 10:55:25 -06:00
parent 76aa80c0e9
commit ef54fc470c
2 changed files with 100 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/gui-pkgs/gui-doc/mrlib/scribblings/terminal.scrbl
View File

@ -18,7 +18,8 @@ in command-line scripts.}
[#:aborted-message aborted-message string? (string-constant plt-installer-aborted)]
[#:canvas-min-width canvas-min-width (or/c #f (integer-in 0 10000)) #f]
[#:canvas-min-height canvas-min-height (or/c #f (integer-in 0 10000)) #f]
[#:close-button? close-button? boolean? #t])
[#:close-button? close-button? boolean? #t]
[#:close-label close-label string? (string-constant close)])
(is-a?/c terminal<%>)]{
Creates a GUI, sets up the current error and output ports to
@ -45,9 +46,9 @@ in command-line scripts.}
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)]). The close button is present only
@racket[close-label]). The close button is present only
if @racket[close-button?] is @racket[#t].
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
@ -96,4 +97,8 @@ enabled).}
Returns a synchronizable event that becomes ready for synchronization
when the terminal GUI can be closed.}
@defmethod[(get-button-panel) (is-a?/c horizontal-panel%)]{
Returns a panel that contains the abort and close buttons.}
}

177
pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt
View File

@ -16,7 +16,8 @@
#:cleanup-thunk (-> void?)
#:canvas-min-width (or/c #f exact-nonnegative-integer?)
#:canvas-min-height (or/c #f exact-nonnegative-integer?)
#:close-button? boolean?)
#:close-button? boolean?
#:close-label string?)
(is-a?/c terminal<%>))])
terminal<%>)
@ -41,7 +42,8 @@
#:cleanup-thunk [cleanup-thunk void]
#:canvas-min-width [canvas-min-width #f]
#:canvas-min-height [canvas-min-height #f]
#:close-button? [close-button? #t])
#:close-button? [close-button? #t]
#:close-label [close-button-label (string-constant close)])
(define orig-eventspace (current-eventspace))
(define orig-custodian (current-custodian))
(define inst-eventspace (if container
@ -67,95 +69,98 @@
(define (close-callback)
(custodian-shutdown-all installer-cust))
(define saved-button-panel #f)
(parameterize ([current-eventspace inst-eventspace])
(queue-callback
(λ ()
(unless container
(set! frame
(new (class frame%
(define/augment (can-close?) currently-can-close?)
(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)))]))
(when container
(send container begin-container-sequence))
(unless container
(set! frame
(new (class frame%
(define/augment (can-close?) currently-can-close?)
(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)))]))
(when container
(send container begin-container-sequence))
(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 sub-container]
[editor text]
[min-width canvas-min-width]
[min-height canvas-min-height]))
(define button-panel (new horizontal-panel%
[parent sub-container]
[stretchable-height #f]
[alignment '(center center)]))
(set! kill-button (new button%
[label abort-label]
[parent button-panel]
[callback (λ (b e) (kill-callback))]))
(when close-button?
(set! close-button (new button%
[label (string-constant close)]
[parent button-panel]
[callback (λ (b e) (close))])))
(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 sub-container]
[editor text]
[min-width canvas-min-width]
[min-height canvas-min-height]))
(define button-panel (new horizontal-panel%
[parent sub-container]
[stretchable-height #f]
[alignment '(center center)]))
(set! kill-button (new button%
[label abort-label]
[parent button-panel]
[callback (λ (b e) (kill-callback))]))
(when close-button?
(set! close-button (new button%
[label close-button-label]
[parent button-panel]
[callback (λ (b e) (close))])))
(define (close)
(if frame
(send frame show #f)
(send container delete-child sub-container))
(close-callback))
(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))
(set! currently-can-close? #f)
(when close-button (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)
(when container
(send container end-container-sequence))
(when frame
(send frame show #t)))))
(define (kill-callback)
(custodian-shutdown-all installer-cust)
(fprintf output-port "\n~a\n" aborted-message))
(set! currently-can-close? #f)
(when close-button (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)
(set! saved-button-panel button-panel)
(semaphore-post setup-sema)
(when container
(send container end-container-sequence))
(when frame
(send frame show #t)))))
(if (equal? inst-eventspace (current-eventspace))
(yield setup-sema)
@ -244,6 +249,8 @@
(new (class* object% (terminal<%>)
(super-new)
(define/public (get-button-panel)
saved-button-panel)
(define/public (can-close-evt)
(semaphore-peek-evt can-close-sema))
(define/public (is-closed?)