319 lines
15 KiB
Racket
319 lines
15 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/string
|
|
(prefix-in wx: "kernel.rkt")
|
|
"const.rkt"
|
|
"check.rkt"
|
|
"helper.rkt"
|
|
"editor.rkt"
|
|
"mrtop.rkt"
|
|
"mrcanvas.rkt"
|
|
"mrpopup.rkt"
|
|
"mrmenu.rkt"
|
|
"mritem.rkt"
|
|
"mrpanel.rkt")
|
|
|
|
(provide message-box
|
|
message-box/custom
|
|
message+check-box
|
|
message+check-box/custom)
|
|
|
|
(define do-message-box/custom
|
|
(lambda (who title message
|
|
button1 button2 button3
|
|
parent style close-result
|
|
check? two-results? check-message
|
|
dialog-mixin)
|
|
(check-label-string who title)
|
|
(check-string/false who message)
|
|
(when check?
|
|
(check-label-string who check-message))
|
|
(check-label-string-or-bitmap/false who button1)
|
|
(check-label-string-or-bitmap/false who button2)
|
|
(check-label-string-or-bitmap/false who button3)
|
|
(check-top-level-parent/false who parent)
|
|
(check-style who
|
|
'(default=1 default=2 default=3 no-default)
|
|
(let ([l '(disallow-close number-order caution stop no-icon)])
|
|
(if check?
|
|
(cons 'checked l)
|
|
l))
|
|
style)
|
|
|
|
(let ([go (lambda ()
|
|
(create-message-box/custom
|
|
who title message
|
|
button1 button2 button3
|
|
parent style close-result
|
|
check? two-results? check-message
|
|
dialog-mixin))]
|
|
[es (if parent
|
|
(send parent get-eventspace)
|
|
(wx:current-eventspace))])
|
|
(if (eq? (current-thread) (wx:eventspace-handler-thread es))
|
|
;; In the right thread:
|
|
(go)
|
|
;; Not in the right thread:
|
|
(let ([ch (make-channel)])
|
|
(parameterize ([wx:current-eventspace es])
|
|
(wx:queue-callback
|
|
(lambda ()
|
|
(channel-put ch (call-with-values go list)))))
|
|
(apply values (channel-get ch)))))))
|
|
|
|
(define create-message-box/custom
|
|
(lambda (who title message
|
|
button1 button2 button3
|
|
parent style close-result
|
|
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 (dialog-mixin
|
|
(class 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))])
|
|
(super-make-object title parent box-width))))]
|
|
[result close-result]
|
|
[icon-id (cond
|
|
[(memq 'no-icon style) #f]
|
|
[(memq 'stop style) 'stop]
|
|
[(memq 'caution style) 'caution]
|
|
[else 'app])])
|
|
(let-values ([(msg-pnl btn-pnl cb-pnl extra-width btn-h-align msg-h-align msg-v-align)
|
|
(case (system-type)
|
|
[(macosx) (let ([p (make-object horizontal-pane% f)])
|
|
(send f min-width 300)
|
|
(send p set-alignment 'center 'top)
|
|
(when icon-id
|
|
(let ([m (make-object message% icon-id p)])
|
|
(send m horiz-margin 16)
|
|
(send m vert-margin 16)))
|
|
(let* ([rhs-pnl (make-object vertical-pane% p)]
|
|
[msg-pnl (make-object vertical-pane% rhs-pnl)]
|
|
[btn-pnl (make-object vertical-pane% rhs-pnl)])
|
|
(send msg-pnl vert-margin 16)
|
|
(when single?
|
|
(send msg-pnl horiz-margin 8))
|
|
(send btn-pnl vert-margin 8)
|
|
(send msg-pnl min-height 40)
|
|
(send msg-pnl min-width 300)
|
|
(send btn-pnl stretchable-height #f)
|
|
(values msg-pnl btn-pnl btn-pnl 96 'right 'left 'top)))]
|
|
[else (let ([p (new horizontal-pane% [parent f] [alignment '(center top)])])
|
|
(let ([icon-msg (and icon-id (make-object message% icon-id p))]
|
|
[msg-pnl (new vertical-pane% [parent p])])
|
|
(values (if (= 1 (length strings))
|
|
(new horizontal-pane%
|
|
[parent msg-pnl]
|
|
[alignment '(center top)]
|
|
[min-height (if icon-msg
|
|
(send icon-msg min-height)
|
|
1)])
|
|
msg-pnl)
|
|
f msg-pnl 0 'center 'center 'center)))])])
|
|
(if single?
|
|
(begin
|
|
(send msg-pnl set-alignment (if (= (length strings) 1) msg-h-align 'left) msg-v-align)
|
|
(for-each (lambda (s) (make-object message% (protect& s) msg-pnl)) strings)
|
|
(send f stretchable-width #f)
|
|
(send f stretchable-height #f))
|
|
;; Try without scrollbar, then add one if necessary:
|
|
(let loop ([scroll? #f])
|
|
(let* ([e (make-object text%)]
|
|
[c (make-object editor-canvas% msg-pnl e (if scroll?
|
|
'(no-hscroll)
|
|
'(no-hscroll no-vscroll transparent no-border)))])
|
|
(send c min-width 400)
|
|
(send c set-line-count 5)
|
|
(send c allow-tab-exit #t)
|
|
(send f reflow-container)
|
|
(send e auto-wrap #t)
|
|
(send e insert message)
|
|
(send e set-position 0)
|
|
(send e hide-caret #t)
|
|
(send e set-cursor (make-object wx:cursor% 'arrow) #t)
|
|
(send e lock #t)
|
|
(when (not scroll?)
|
|
;; Check whether it actually fits
|
|
(let ([vh (box 0)]
|
|
[eh (box 0)])
|
|
(send e get-view-size #f vh)
|
|
(send e get-extent #f eh)
|
|
(unless ((unbox eh) . <= . (unbox vh))
|
|
(send c show #f)
|
|
(send msg-pnl delete-child c)
|
|
(loop #t)))))))
|
|
(let ([check (and check?
|
|
(let ([p (new vertical-pane% [parent cb-pnl]
|
|
[stretchable-height #f]
|
|
[alignment '(left center)])])
|
|
(when (and single?
|
|
(eq? 'macosx (system-type)))
|
|
;; Match text-panel margin:
|
|
(send p horiz-margin 8))
|
|
(new check-box%
|
|
[label check-message]
|
|
[parent p]
|
|
[callback void]
|
|
[value (memq 'checked style)])))])
|
|
(let* ([p (make-object horizontal-pane% btn-pnl)]
|
|
[mk-button (lambda (title v default?)
|
|
(let ([b (make-object button% title p (lambda (b e) (set! result v) (send f show #f))
|
|
(if default? '(border) null))])
|
|
(when default? (send b focus))))])
|
|
(send p set-alignment btn-h-align 'center)
|
|
(send p stretchable-height #f)
|
|
(send p stretchable-width #t) ; to get panel's centering
|
|
(let ([mk-1 (lambda ()
|
|
(when button1
|
|
(mk-button button1 1 (memq 'default=1 style))))]
|
|
[mk-2 (lambda ()
|
|
(when button2
|
|
(mk-button button2 2 (memq 'default=2 style))))]
|
|
[mk-3 (lambda ()
|
|
(when button3
|
|
(mk-button button3 3 (memq 'default=3 style))))])
|
|
(cond
|
|
[(or (memq 'number-order style)
|
|
(memq (system-type) '(windows)))
|
|
(mk-1)
|
|
(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/custom
|
|
(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 dialog-mixin)))
|
|
|
|
(define do-message-box
|
|
(lambda (who title message parent style check? check-message dialog-mixin)
|
|
(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 no-icon)])
|
|
(if check?
|
|
(cons 'checked l)
|
|
l))
|
|
style)
|
|
|
|
(let-values ([(one two one-v two-v close-val default)
|
|
(cond
|
|
[(memq 'ok style)
|
|
(values "OK" #f 'ok #f 1 'default=1)]
|
|
[(memq 'ok-cancel style)
|
|
(values "OK" "Cancel" 'ok 'cancel 2 'default=1)]
|
|
[(memq 'yes-no style)
|
|
(values "&Yes" "&No" 'yes 'no #f 'no-default)])])
|
|
(let-values ([(result checked?)
|
|
(do-message-box/custom who
|
|
title message
|
|
one two #f
|
|
parent
|
|
(append
|
|
(cond
|
|
[(memq 'checked style) '(checked)]
|
|
[else null])
|
|
(cond
|
|
[(memq 'no-icon style) '(no-icon)]
|
|
[(memq 'stop style) '(stop)]
|
|
[(memq 'caution style) '(caution)]
|
|
[else null])
|
|
(if close-val
|
|
(list default)
|
|
(list default 'disallow-close)))
|
|
close-val
|
|
check? #t check-message
|
|
dialog-mixin)])
|
|
(let ([result (case result
|
|
[(1) one-v]
|
|
[(2) two-v])])
|
|
(if check?
|
|
(values result checked?)
|
|
result))))))
|
|
|
|
(define message-box
|
|
(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
|
|
(lambda (title message
|
|
checkbox-message
|
|
button1
|
|
button2
|
|
button3
|
|
[parent #f]
|
|
[style '(no-default)]
|
|
[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
|
|
dialog-mixin)))
|
|
|
|
(define message+check-box
|
|
(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)))
|