From 8d75df199f368dbebabfe505b9b017f6a017db89 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Sep 2011 21:41:22 -0500 Subject: [PATCH] added a #:dialog-mixin argument to message-box and related functions Also minor rackety (just enough to get keyword arguments) original commit: 92537076211b5b2c111ad8f8482c8354a8335029 --- collects/mred/private/messagebox.rkt | 137 ++++++++++---------- collects/scribblings/gui/dialog-funcs.scrbl | 32 +++-- 2 files changed, 92 insertions(+), 77 deletions(-) diff --git a/collects/mred/private/messagebox.rkt b/collects/mred/private/messagebox.rkt index a9eb6d09..56b9c430 100644 --- a/collects/mred/private/messagebox.rkt +++ b/collects/mred/private/messagebox.rkt @@ -1,9 +1,8 @@ -(module messagebox mzscheme +#lang racket/base (require mzlib/class mzlib/class100 - mzlib/etc mzlib/string - (prefix wx: "kernel.rkt") + (prefix-in wx: "kernel.rkt") "const.rkt" "check.rkt" "helper.rkt" @@ -24,7 +23,8 @@ (lambda (who title message button1 button2 button3 parent style close-result - check? two-results? check-message) + check? two-results? check-message + dialog-mixin) (check-label-string who title) (check-string/false who message) (when check? @@ -46,7 +46,8 @@ who title message button1 button2 button3 parent style close-result - check? two-results? check-message))] + check? two-results? check-message + dialog-mixin))] [es (if parent (send parent get-eventspace) (wx:current-eventspace))]) @@ -65,51 +66,53 @@ (lambda (who title message button1 button2 button3 parent style close-result - check? two-results? check-message) + check? two-results? check-message + dialog-mixin) (let* ([strings (regexp-split #rx"\n" message)] [single? (and (< (length strings) 10) (andmap (lambda (s) (< (string-length s) 60)) strings))] - [f (make-object (class100 dialog% () - (public - [get-message - (lambda () message)]) - (augment - [can-close? (lambda () - (if (memq 'disallow-close style) - (begin - (wx:bell) - #f) - #t))]) - (override - [on-subwindow-event - (lambda (w e) - (if (send e button-down?) - (if (is-a? w button%) - #f - (if (or (is-a? w message%) - (and - (is-a? w editor-canvas%) - (let-values ([(w h) (send w get-client-size)]) - (< (send e get-x) w)))) - (begin - (send w popup-menu - (let ([m (make-object popup-menu%)]) - (make-object menu-item% - "Copy Message" - m - (lambda (i e) - (send (wx:get-the-clipboard) - set-clipboard-string - message - (send e get-time-stamp)))) - m) - (send e get-x) - (send e get-y)) - #t) - #f)) - #f))]) - (sequence - (super-init title parent box-width))))] + [f (make-object (dialog-mixin + (class100 dialog% () + (public + [get-message + (lambda () message)]) + (augment + [can-close? (lambda () + (if (memq 'disallow-close style) + (begin + (wx:bell) + #f) + #t))]) + (override + [on-subwindow-event + (lambda (w e) + (if (send e button-down?) + (if (is-a? w button%) + #f + (if (or (is-a? w message%) + (and + (is-a? w editor-canvas%) + (let-values ([(w h) (send w get-client-size)]) + (< (send e get-x) w)))) + (begin + (send w popup-menu + (let ([m (make-object popup-menu%)]) + (make-object menu-item% + "Copy Message" + m + (lambda (i e) + (send (wx:get-the-clipboard) + set-clipboard-string + message + (send e get-time-stamp)))) + m) + (send e get-x) + (send e get-y)) + #t) + #f)) + #f))]) + (sequence + (super-init title parent box-width)))))] [result close-result] [icon-id (cond [(memq 'stop style) 'stop] @@ -224,20 +227,21 @@ result)))))) (define message-box/custom - (opt-lambda (title message - button1 - button2 - button3 - [parent #f] - [style '(no-default)] - [close-result #f]) + (lambda (title message + button1 + button2 + button3 + [parent #f] + [style '(no-default)] + [close-result #f] + #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message-box/custom title message button1 button2 button3 parent style close-result - #f #f #f))) + #f #f #f dialog-mixin))) (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-string/false who message) (when check? @@ -276,7 +280,8 @@ (list default) (list default 'disallow-close))) close-val - check? #t check-message)]) + check? #t check-message + dialog-mixin)]) (let ([result (case result [(1) one-v] [(2) two-v])]) @@ -285,23 +290,25 @@ result)))))) (define message-box - (opt-lambda (title message [parent #f] [style '(ok)]) - (do-message-box 'message-box title message parent style #f #f))) + (lambda (title message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values]) + (do-message-box 'message-box title message parent style #f #f dialog-mixin))) (define message+check-box/custom - (opt-lambda (title message + (lambda (title message checkbox-message button1 button2 button3 [parent #f] [style '(no-default)] - [close-result #f]) + [close-result #f] + #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message+check-box/custom title message button1 button2 button3 - parent style close-result - #t #t checkbox-message))) + parent style close-result + #t #t checkbox-message + dialog-mixin))) (define message+check-box - (opt-lambda (title message check-message [parent #f] [style '(ok)]) - (do-message-box 'message-box title message parent style #t check-message)))) + (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 dialog-mixin))) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index cc744dfc..4299af6f 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -196,7 +196,8 @@ See also @racket[path-dialog%] for a richer interface. @defproc[(message-box [title label-string?] [message string?] [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)]{ 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 @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 @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?] [message string] @@ -254,7 +259,8 @@ The @racket[message-box] function can be called int a thread other 'disallow-close 'no-default 'default=1 'default=2 'default=3)) '(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)]{ 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 @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 @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?] [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] [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop 'checked)) - '(ok)]) + '(ok)] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (values (or/c 'ok 'cancel 'yes 'no) boolean?)]{ See also @racket[message+check-box/custom]. @@ -361,7 +372,8 @@ Like @racket[message-box], except that 'disallow-close 'no-default 'default=1 'default=2 'default=3)) '(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)))]{ 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 should be initially checked.} ] - - - - } @defproc[(get-text-from-user [title string?]