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

in-terminal: add a close-calllback argument

Browse Source 
original commit: 4fee662ad87a50a700cde42847e563c03024a845
This commit is contained in:
Matthew Flatt 2014-11-25 11:30:01 -07:00
parent 3bac3723b9
commit f2dab2b828
3 changed files with 23 additions and 18 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

@ -19,7 +19,8 @@ in command-line scripts.}
[#: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-label close-label string? (string-constant close)])
[#:close-label close-label string? (string-constant close)]
[#:close-callback close-callback (-> any) void])
(is-a?/c terminal<%>)]{
Creates a GUI, sets up the current error and output ports to
@ -40,7 +41,7 @@ in command-line scripts.}
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
eventspace active when @racket[in-terminal] is invoked
after @racket[doit] completes.
In addition to the I/O generated by @racket[doit], the generated GUI
@ -66,7 +67,11 @@ in command-line scripts.}
The value of @racket[on-terminal-run] is invoked after @racket[doit]
returns, but not if it is aborted or an exception is raised.
}
The @racket[close-callback] function is called after the terminal
frame is closed or container is removed.
@history[#:changed "1.4" @elem{Added the @racket[#:close-callback] argument.}]}
@defparam[on-terminal-run run (-> void?)]{
Invoked by @racket[in-terminal].

2
pkgs/gui-pkgs/gui-lib/info.rkt
View File

@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby))
(define version "1.3")
(define version "1.4")

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

@ -17,7 +17,8 @@
#:canvas-min-width (or/c #f exact-nonnegative-integer?)
#:canvas-min-height (or/c #f exact-nonnegative-integer?)
#:close-button? boolean?
#:close-label string?)
#:close-label string?
#:close-callback (-> any))
(is-a?/c terminal<%>))])
terminal<%>)
@ -43,7 +44,8 @@
#:canvas-min-width [canvas-min-width #f]
#:canvas-min-height [canvas-min-height #f]
#:close-button? [close-button? #t]
#:close-label [close-button-label (string-constant close)])
#:close-label [close-button-label (string-constant close)]
#:close-callback [user-close-callback void])
(define orig-eventspace (current-eventspace))
(define orig-custodian (current-custodian))
(define inst-eventspace (if container
@ -65,7 +67,8 @@
(if frame
(send frame show #f)
(send container delete-child sub-container))
(close-callback))
(close-callback)
(user-close-callback))
(define (close-callback)
(custodian-shutdown-all installer-cust))
@ -78,7 +81,9 @@
(set! frame
(new (class frame%
(define/augment (can-close?) currently-can-close?)
(define/augment (on-close) (close-callback))
(define/augment (on-close)
(close-callback)
(user-close-callback))
(super-new [label title]
[width 600]
[height 300]))))
@ -116,7 +121,8 @@
(new (class vertical-panel%
(super-new)
(define/override (on-superwindow-show on?)
(unless on? (close-callback))))
(unless on?
(close-callback))))
[parent container])))
(set! text (new (text:hide-caret/selection-mixin text:standard-style-list%)))
@ -139,12 +145,6 @@
[parent button-panel]
[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))
@ -253,6 +253,8 @@
(cleanup-thunk)
(custodian-shutdown-all installer-cust))))))))
(define (outside-close) (close))
(new (class* object% (terminal<%>)
(super-new)
(define/public (get-button-panel)
@ -265,6 +267,4 @@
currently-can-close?)
(define/public (close)
(unless (is-closed?)
(if frame
(send frame show #f)
(send container delete-child sub-container)))))))
(outside-close))))))