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)] [#: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-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] [#: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<%>)]{ (is-a?/c terminal<%>)]{
Creates a GUI, sets up the current error and output ports to 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 In addition to the I/O generated by @racket[doit], the generated GUI
contains two buttons: the abort button (with label contains two buttons: the abort button (with label
@racket[abort-label]) and the close 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]. if @racket[close-button?] is @racket[#t].
When the abort button is pushed, When the abort button is pushed,
the newly created custodian is shut down and the the newly created custodian is shut down and the
@racket[aborted-message] is printed in the dialog. The close button @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 Returns a synchronizable event that becomes ready for synchronization
when the terminal GUI can be closed.} 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?) #:cleanup-thunk (-> void?)
#:canvas-min-width (or/c #f exact-nonnegative-integer?) #:canvas-min-width (or/c #f exact-nonnegative-integer?)
#:canvas-min-height (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<%>))]) (is-a?/c terminal<%>))])
terminal<%>) terminal<%>)
@ -41,7 +42,8 @@
#:cleanup-thunk [cleanup-thunk void] #:cleanup-thunk [cleanup-thunk void]
#:canvas-min-width [canvas-min-width #f] #:canvas-min-width [canvas-min-width #f]
#:canvas-min-height [canvas-min-height #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-eventspace (current-eventspace))
(define orig-custodian (current-custodian)) (define orig-custodian (current-custodian))
(define inst-eventspace (if container (define inst-eventspace (if container
@ -67,95 +69,98 @@
(define (close-callback) (define (close-callback)
(custodian-shutdown-all installer-cust)) (custodian-shutdown-all installer-cust))
(define saved-button-panel #f)
(parameterize ([current-eventspace inst-eventspace]) (parameterize ([current-eventspace inst-eventspace])
(queue-callback (queue-callback
(λ () (λ ()
(unless container (unless container
(set! frame (set! frame
(new (class frame% (new (class frame%
(define/augment (can-close?) currently-can-close?) (define/augment (can-close?) currently-can-close?)
(define/augment (on-close) (close-callback)) (define/augment (on-close) (close-callback))
(super-new [label title] (super-new [label title]
[width 600] [width 600]
[height 300])))) [height 300]))))
(set! container frame) (set! container frame)
(define mb (new menu-bar% [parent frame])) (define mb (new menu-bar% [parent frame]))
(define edit-menu (new menu% (define edit-menu (new menu%
[label (string-constant edit-menu)] [label (string-constant edit-menu)]
[parent mb])) [parent mb]))
(define copy-menu-item (define copy-menu-item
(new menu-item% (new menu-item%
[parent edit-menu] [parent edit-menu]
[label (string-constant copy-menu-item)] [label (string-constant copy-menu-item)]
[shortcut #\c] [shortcut #\c]
[demand-callback [demand-callback
(λ (item) (λ (item)
(send copy-menu-item enable (send copy-menu-item enable
(not (= (send text get-start-position) (not (= (send text get-start-position)
(send text get-end-position)))))] (send text get-end-position)))))]
[callback [callback
(λ (item evt) (λ (item evt)
(send text copy))])) (send text copy))]))
(new menu-item% (new menu-item%
[parent edit-menu] [parent edit-menu]
[label (string-constant select-all-menu-item)] [label (string-constant select-all-menu-item)]
[shortcut #\a] [shortcut #\a]
[callback [callback
(λ (item evt) (λ (item evt)
(send text set-position 0 (send text last-position)))])) (send text set-position 0 (send text last-position)))]))
(when container (when container
(send container begin-container-sequence)) (send container begin-container-sequence))
(set! sub-container (set! sub-container
(or frame (or frame
(new (class vertical-panel% (new (class vertical-panel%
(super-new) (super-new)
(define/override (on-superwindow-show on?) (define/override (on-superwindow-show on?)
(unless on? (close-callback)))) (unless on? (close-callback))))
[parent container]))) [parent container])))
(set! text (new (text:hide-caret/selection-mixin text:standard-style-list%))) (set! text (new (text:hide-caret/selection-mixin text:standard-style-list%)))
(define canvas (new editor-canvas% (define canvas (new editor-canvas%
[parent sub-container] [parent sub-container]
[editor text] [editor text]
[min-width canvas-min-width] [min-width canvas-min-width]
[min-height canvas-min-height])) [min-height canvas-min-height]))
(define button-panel (new horizontal-panel% (define button-panel (new horizontal-panel%
[parent sub-container] [parent sub-container]
[stretchable-height #f] [stretchable-height #f]
[alignment '(center center)])) [alignment '(center center)]))
(set! kill-button (new button% (set! kill-button (new button%
[label abort-label] [label abort-label]
[parent button-panel] [parent button-panel]
[callback (λ (b e) (kill-callback))])) [callback (λ (b e) (kill-callback))]))
(when close-button? (when close-button?
(set! close-button (new button% (set! close-button (new button%
[label (string-constant close)] [label close-button-label]
[parent button-panel] [parent button-panel]
[callback (λ (b e) (close))]))) [callback (λ (b e) (close))])))
(define (close) (define (close)
(if frame (if frame
(send frame show #f) (send frame show #f)
(send container delete-child sub-container)) (send container delete-child sub-container))
(close-callback)) (close-callback))
(define (kill-callback) (define (kill-callback)
(custodian-shutdown-all installer-cust) (custodian-shutdown-all installer-cust)
(fprintf output-port "\n~a\n" aborted-message)) (fprintf output-port "\n~a\n" aborted-message))
(set! currently-can-close? #f) (set! currently-can-close? #f)
(when close-button (send close-button enable #f)) (when close-button (send close-button enable #f))
(send canvas allow-tab-exit #t) (send canvas allow-tab-exit #t)
((current-text-keymap-initializer) (send text get-keymap)) ((current-text-keymap-initializer) (send text get-keymap))
(send text set-styles-sticky #f) (send text set-styles-sticky #f)
(send text lock #t) (send text lock #t)
(send text hide-caret #t) (send text hide-caret #t)
(semaphore-post setup-sema) (set! saved-button-panel button-panel)
(when container (semaphore-post setup-sema)
(send container end-container-sequence)) (when container
(when frame (send container end-container-sequence))
(send frame show #t))))) (when frame
(send frame show #t)))))
(if (equal? inst-eventspace (current-eventspace)) (if (equal? inst-eventspace (current-eventspace))
(yield setup-sema) (yield setup-sema)
@ -244,6 +249,8 @@
(new (class* object% (terminal<%>) (new (class* object% (terminal<%>)
(super-new) (super-new)
(define/public (get-button-panel)
saved-button-panel)
(define/public (can-close-evt) (define/public (can-close-evt)
(semaphore-peek-evt can-close-sema)) (semaphore-peek-evt can-close-sema))
(define/public (is-closed?) (define/public (is-closed?)