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

.

Browse Source 
original commit: 853345495ca3f11b4d5d257d693e2c50d1bfb939
This commit is contained in:
Matthew Flatt 2004-09-01 00:27:16 +00:00
parent 06f061b621
commit 694dae944c
2 changed files with 138 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/mred-sig.ss
View File

@ -122,7 +122,9 @@
menu-item<%> menu-item<%>
message% message%
message-box message-box
message+check-box
message-box/custom message-box/custom
message+check-box/custom
mouse-event% mouse-event%
;; mred@ ;; mred@
mult-color<%> mult-color<%>

206
collects/mred/mred.ss
View File

@ -6123,23 +6123,25 @@
(regexp-replace* #rx"&" s "\\&\\&"))) (regexp-replace* #rx"&" s "\\&\\&")))
(define message-box/custom (define do-message-box/custom
(opt-lambda (title message (lambda (who title message
button1 button1 button2 button3
button2 parent style close-result
button3 check? two-results? check-message)
[parent #f] (check-label-string who title)
[style '(no-default)] (check-string/false who message)
[close-result #f]) (when check?
(check-label-string 'message-box/custom title) (check-label-string who check-message))
(check-string/false 'message-box/custom message) (check-label-string-or-bitmap/false who button1)
(check-label-string-or-bitmap/false 'message-box/custom button1) (check-label-string-or-bitmap/false who button2)
(check-label-string-or-bitmap/false 'message-box/custom button2) (check-label-string-or-bitmap/false who button3)
(check-label-string-or-bitmap/false 'message-box/custom button3) (check-top-level-parent/false who parent)
(check-top-level-parent/false 'message-box/custom parent) (check-style who
(check-style 'message-box/custom
'(default=1 default=2 default=3 no-default) '(default=1 default=2 default=3 no-default)
'(disallow-close number-order caution stop) (let ([l '(disallow-close number-order caution stop)])
(if check?
(cons 'checked l)
l))
style) style)
(let* ([strings (let loop ([s message]) (let* ([strings (let loop ([s message])
@ -6248,47 +6250,76 @@
(send c show #f) (send c show #f)
(send msg-pnl delete-child c) (send msg-pnl delete-child c)
(loop #t))))))) (loop #t)))))))
(let* ([p (make-object horizontal-pane% btn-pnl)] (let ([check (and check?
[mk-button (lambda (title v default?) (let ([p (new horizontal-pane% [parent btn-pnl]
(let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f)) [stretchable-height #f]
(if default? '(border) null))]) [alignment '(left center)])])
(when default? (send b focus))))]) (new check-box%
(send p set-alignment btn-h-align 'center) [label check-message]
(send p stretchable-height #f) [parent p]
(send p stretchable-width #t) ; to get panel's centering [callback void]
(let ([mk-1 (lambda () [value (memq 'checked style)])))])
(when button1 (let* ([p (make-object horizontal-pane% btn-pnl)]
(mk-button button1 1 (memq 'default=1 style))))] [mk-button (lambda (title v default?)
[mk-2 (lambda () (let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f))
(when button2 (if default? '(border) null))])
(mk-button button2 2 (memq 'default=2 style))))] (when default? (send b focus))))])
[mk-3 (lambda () (send p set-alignment btn-h-align 'center)
(when button3 (send p stretchable-height #f)
(mk-button button3 3 (memq 'default=3 style))))]) (send p stretchable-width #t) ; to get panel's centering
(cond (let ([mk-1 (lambda ()
[(or (memq 'number-order style) (when button1
(not (memq (system-type) '(macos macosx)))) (mk-button button1 1 (memq 'default=1 style))))]
(mk-1) [mk-2 (lambda ()
(mk-2) (when button2
(mk-3)] (mk-button button2 2 (memq 'default=2 style))))]
[else [mk-3 (lambda ()
(mk-3) (when button3
(make-object horizontal-pane% p) (mk-button button3 3 (memq 'default=3 style))))])
(mk-2) (cond
(mk-1)]))) [(or (memq 'number-order style)
(send f center) (not (memq (system-type) '(macos macosx))))
(send f show #t) (mk-1)
result)))) (mk-2)
(mk-3)]
[else
(mk-3)
(make-object horizontal-pane% p)
(mk-2)
(mk-1)])))
(send f center)
(send f show #t)
(if two-results?
(values result (and check? (send check get-value)))
result))))))
(define message-box (define message-box/custom
(case-lambda (opt-lambda (title message
[(title message) (message-box title message #f '(ok))] button1
[(title message parent) (message-box title message parent '(ok))] button2
[(title message parent style) button3
(check-label-string 'message-box title) [parent #f]
(check-string/false 'message-box message) [style '(no-default)]
(check-top-level-parent/false 'message-box parent) [close-result #f])
(check-style 'message-box '(ok ok-cancel yes-no) '(caution stop) style) (do-message-box/custom 'message-box/custom
title message button1 button2 button3
parent style close-result
#f #f #f)))
(define do-message-box
(opt-lambda (who title message parent style check? check-message)
(check-label-string who title)
(check-string/false who message)
(when check?
(check-label-string who check-message))
(check-top-level-parent/false who parent)
(check-style who
'(ok ok-cancel yes-no)
(let ([l '(caution stop)])
(if check?
(cons 'checked l)
l))
style)
(let-values ([(one two one-v two-v close-val default) (let-values ([(one two one-v two-v close-val default)
(cond (cond
@ -6298,20 +6329,53 @@
(values "OK" "Cancel" 'ok 'cancel 2 'default=1)] (values "OK" "Cancel" 'ok 'cancel 2 'default=1)]
[(memq 'yes-no style) [(memq 'yes-no style)
(values "&Yes" "&No" 'yes 'no #f 'no-default)])]) (values "&Yes" "&No" 'yes 'no #f 'no-default)])])
(case (message-box/custom title message (let-values ([(result checked?)
one two #f (do-message-box/custom who
parent title message
(append one two #f
(cond parent
[(memq 'stop style) '(stop)] (append
[(memq 'caution style) '(caution)] (cond
[else null]) [(memq 'checked style) '(checked)]
(if close-val [else null])
(list default) (cond
(list default 'disallow-close))) [(memq 'stop style) '(stop)]
close-val) [(memq 'caution style) '(caution)]
[(1) one-v] [else null])
[(2) two-v]))])) (if close-val
(list default)
(list default 'disallow-close)))
close-val
check? #t check-message)])
(let ([result (case result
[(1) one-v]
[(2) two-v])])
(if check?
(values result checked?)
result))))))
(define message-box
(opt-lambda (title message [parent #f] [style '(ok)])
(do-message-box 'message-box title message parent style #f #f)))
(define message+check-box/custom
(opt-lambda (title message
checkbox-message
button1
button2
button3
[parent #f]
[style '(no-default)]
[close-result #f])
(do-message-box/custom 'message+check-box/custom
title message button1 button2 button3
parent style close-result
#t #t checkbox-message)))
(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)))
(define (number->string* n) (define (number->string* n)
(let ([s (number->string n)]) (let ([s (number->string n)])
@ -7952,7 +8016,9 @@
pasteboard% pasteboard%
graphical-read-eval-print-loop graphical-read-eval-print-loop
message-box message-box
message+check-box
message-box/custom message-box/custom
message+check-box/custom
get-file get-file
get-file-list get-file-list
put-file put-file