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

added a #:dialog-mixin argument to message-box and related functions

Browse Source 
Also minor rackety (just enough to get keyword arguments)
This commit is contained in:
Robby Findler 2011-09-03 21:41:22 -05:00
parent 415868f914
commit 9253707621
2 changed files with 92 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
collects/mred/private/messagebox.rkt
View File

@ -1,9 +1,8 @@
(module messagebox mzscheme #lang racket/base
(require mzlib/class (require mzlib/class
mzlib/class100 mzlib/class100
mzlib/etc
mzlib/string mzlib/string
(prefix wx: "kernel.rkt") (prefix-in wx: "kernel.rkt")
"const.rkt" "const.rkt"
"check.rkt" "check.rkt"
"helper.rkt" "helper.rkt"
@ -24,7 +23,8 @@
(lambda (who title message (lambda (who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message) check? two-results? check-message
dialog-mixin)
(check-label-string who title) (check-label-string who title)
(check-string/false who message) (check-string/false who message)
(when check? (when check?
@ -46,7 +46,8 @@
who title message who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message))] check? two-results? check-message
dialog-mixin))]
[es (if parent [es (if parent
(send parent get-eventspace) (send parent get-eventspace)
(wx:current-eventspace))]) (wx:current-eventspace))])
@ -65,51 +66,53 @@
(lambda (who title message (lambda (who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message) check? two-results? check-message
dialog-mixin)
(let* ([strings (regexp-split #rx"\n" message)] (let* ([strings (regexp-split #rx"\n" message)]
[single? (and (< (length strings) 10) [single? (and (< (length strings) 10)
(andmap (lambda (s) (< (string-length s) 60)) strings))] (andmap (lambda (s) (< (string-length s) 60)) strings))]
[f (make-object (class100 dialog% () [f (make-object (dialog-mixin
(public (class100 dialog% ()
[get-message (public
(lambda () message)]) [get-message
(augment (lambda () message)])
[can-close? (lambda () (augment
(if (memq 'disallow-close style) [can-close? (lambda ()
(begin (if (memq 'disallow-close style)
(wx:bell) (begin
#f) (wx:bell)
#t))]) #f)
(override #t))])
[on-subwindow-event (override
(lambda (w e) [on-subwindow-event
(if (send e button-down?) (lambda (w e)
(if (is-a? w button%) (if (send e button-down?)
#f (if (is-a? w button%)
(if (or (is-a? w message%) #f
(and (if (or (is-a? w message%)
(is-a? w editor-canvas%) (and
(let-values ([(w h) (send w get-client-size)]) (is-a? w editor-canvas%)
(< (send e get-x) w)))) (let-values ([(w h) (send w get-client-size)])
(begin (< (send e get-x) w))))
(send w popup-menu (begin
(let ([m (make-object popup-menu%)]) (send w popup-menu
(make-object menu-item% (let ([m (make-object popup-menu%)])
"Copy Message" (make-object menu-item%
m "Copy Message"
(lambda (i e) m
(send (wx:get-the-clipboard) (lambda (i e)
set-clipboard-string (send (wx:get-the-clipboard)
message set-clipboard-string
(send e get-time-stamp)))) message
m) (send e get-time-stamp))))
(send e get-x) m)
(send e get-y)) (send e get-x)
#t) (send e get-y))
#f)) #t)
#f))]) #f))
(sequence #f))])
(super-init title parent box-width))))] (sequence
(super-init title parent box-width)))))]
[result close-result] [result close-result]
[icon-id (cond [icon-id (cond
[(memq 'stop style) 'stop] [(memq 'stop style) 'stop]
@ -224,20 +227,21 @@
result)))))) result))))))
(define message-box/custom (define message-box/custom
(opt-lambda (title message (lambda (title message
button1 button1
button2 button2
button3 button3
[parent #f] [parent #f]
[style '(no-default)] [style '(no-default)]
[close-result #f]) [close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message-box/custom (do-message-box/custom 'message-box/custom
title message button1 button2 button3 title message button1 button2 button3
parent style close-result parent style close-result
#f #f #f))) #f #f #f dialog-mixin)))
(define do-message-box (define do-message-box
(lambda (who title message parent style check? check-message) (lambda (who title message parent style check? check-message dialog-mixin)
(check-label-string who title) (check-label-string who title)
(check-string/false who message) (check-string/false who message)
(when check? (when check?
@ -276,7 +280,8 @@
(list default) (list default)
(list default 'disallow-close))) (list default 'disallow-close)))
close-val close-val
check? #t check-message)]) check? #t check-message
dialog-mixin)])
(let ([result (case result (let ([result (case result
[(1) one-v] [(1) one-v]
[(2) two-v])]) [(2) two-v])])
@ -285,23 +290,25 @@
result)))))) result))))))
(define message-box (define message-box
(opt-lambda (title message [parent #f] [style '(ok)]) (lambda (title message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values])
(do-message-box 'message-box title message parent style #f #f))) (do-message-box 'message-box title message parent style #f #f dialog-mixin)))
(define message+check-box/custom (define message+check-box/custom
(opt-lambda (title message (lambda (title message
checkbox-message checkbox-message
button1 button1
button2 button2
button3 button3
[parent #f] [parent #f]
[style '(no-default)] [style '(no-default)]
[close-result #f]) [close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message+check-box/custom (do-message-box/custom 'message+check-box/custom
title message button1 button2 button3 title message button1 button2 button3
parent style close-result parent style close-result
#t #t checkbox-message))) #t #t checkbox-message
dialog-mixin)))
(define message+check-box (define message+check-box
(opt-lambda (title message check-message [parent #f] [style '(ok)]) (lambda (title message check-message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values])
(do-message-box 'message-box title message parent style #t check-message)))) (do-message-box 'message-box title message parent style #t check-message dialog-mixin)))

32
collects/scribblings/gui/dialog-funcs.scrbl
View File

@ -196,7 +196,8 @@ See also @racket[path-dialog%] for a richer interface.
@defproc[(message-box [title label-string?] @defproc[(message-box [title label-string?]
[message string?] [message string?]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)]) [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 'ok 'cancel 'yes 'no)]{ (or/c 'ok 'cancel 'yes 'no)]{
See also @racket[message-box/custom]. See also @racket[message-box/custom].
@ -239,10 +240,14 @@ The class that implements the dialog provides a @racket[get-message]
a string. (The dialog is accessible through the a string. (The dialog is accessible through the
@racket[get-top-level-windows] function.) @racket[get-top-level-windows] function.)
The @racket[message-box] function can be called int a thread other The @racket[message-box] function can be called in a thread other
than the handler thread of the relevant eventspace (i.e., the eventspace of than the handler thread of the relevant eventspace (i.e., the eventspace of
@racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the
current thread blocks while the dialog runs on the handler thread.} current thread blocks while the dialog runs on the handler thread.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.
}
@defproc[(message-box/custom [title label-string?] @defproc[(message-box/custom [title label-string?]
[message string] [message string]
@ -254,7 +259,8 @@ The @racket[message-box] function can be called int a thread other
'disallow-close 'no-default 'disallow-close 'no-default
'default=1 'default=2 'default=3)) 'default=1 'default=2 'default=3))
'(no-default)] '(no-default)]
[close-result any/c #f]) [close-result any/c #f]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 1 2 3 close-result)]{ (or/c 1 2 3 close-result)]{
Displays a message to the user in a (modal) dialog, using Displays a message to the user in a (modal) dialog, using
@ -324,10 +330,14 @@ The class that implements the dialog provides a @racket[get-message]
a string. (The dialog is accessible through the a string. (The dialog is accessible through the
@racket[get-top-level-windows] function.) @racket[get-top-level-windows] function.)
The @racket[message-box/custom] function can be called int a thread The @racket[message-box/custom] function can be called in a thread
other than the handler thread of the relevant eventspace (i.e., the eventspace of other than the handler thread of the relevant eventspace (i.e., the eventspace of
@racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the
current thread blocks while the dialog runs on the handler thread.} current thread blocks while the dialog runs on the handler thread.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.
}
@defproc[(message+check-box [title label-string?] @defproc[(message+check-box [title label-string?]
[message string?] [message string?]
@ -335,7 +345,8 @@ The @racket[message-box/custom] function can be called int a thread
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[style (listof (or/c 'ok 'ok-cancel 'yes-no [style (listof (or/c 'ok 'ok-cancel 'yes-no
'caution 'stop 'checked)) 'caution 'stop 'checked))
'(ok)]) '(ok)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(values (or/c 'ok 'cancel 'yes 'no) boolean?)]{ (values (or/c 'ok 'cancel 'yes 'no) boolean?)]{
See also @racket[message+check-box/custom]. See also @racket[message+check-box/custom].
@ -361,7 +372,8 @@ Like @racket[message-box], except that
'disallow-close 'no-default 'disallow-close 'no-default
'default=1 'default=2 'default=3)) 'default=1 'default=2 'default=3))
'(no-default)] '(no-default)]
[close-result any/c #f]) [close-result any/c #f]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 1 2 3 (λ (x) (eq? x close-result)))]{ (or/c 1 2 3 (λ (x) (eq? x close-result)))]{
Like @racket[message-box/custom], except that Like @racket[message-box/custom], except that
@ -372,10 +384,6 @@ Like @racket[message-box/custom], except that
@item{@racket[style] can contain @racket['checked] to indicate that the check box @item{@racket[style] can contain @racket['checked] to indicate that the check box
should be initially checked.} should be initially checked.}
] ]
} }
@defproc[(get-text-from-user [title string?] @defproc[(get-text-from-user [title string?]