#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)))