120 lines
5.2 KiB
Scheme
120 lines
5.2 KiB
Scheme
(module gui-defs mzscheme
|
|
(require (lib "unitsig.ss") (lib "class.ss") (lib "mred.ss" "mred")
|
|
(lib "string-constant.ss" "string-constants")
|
|
"checksigs.ss")
|
|
(provide gui-defs@)
|
|
(define gui-defs@
|
|
(unit/sig defs^ (import)
|
|
|
|
(define (run-thunk th)
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(queue-callback th)))
|
|
|
|
;; string (list string (listof string)) (union (listof string) #f) -> void
|
|
(define (show-ok title captions details ok-thunk)
|
|
(letrec ([frame
|
|
(instantiate frame% ()
|
|
[label title]
|
|
[min-width 50]
|
|
[alignment '(left center)]
|
|
[stretchable-height #f]
|
|
[stretchable-width #f]
|
|
[style '(no-resize-border)])]
|
|
[main-panel (instantiate vertical-panel% ()
|
|
[parent frame]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[alignment '(center center)])]
|
|
[panel-sep 4]
|
|
[msg-width 50]
|
|
[make-make-panel
|
|
(lambda (c%)
|
|
(lambda ()
|
|
(instantiate c% ()
|
|
[parent main-panel]
|
|
[vert-margin panel-sep]
|
|
[alignment '(center center)])))]
|
|
[make-hpanel (make-make-panel horizontal-panel%)]
|
|
[make-vpanel (make-make-panel vertical-panel%)]
|
|
[row-panel (make-vpanel)]
|
|
[make-msg
|
|
(lambda (msg panel)
|
|
(instantiate message% ()
|
|
[min-width msg-width] [label msg] [parent panel]))]
|
|
[status-msgs (map (lambda (msg) (make-msg msg row-panel))
|
|
captions)]
|
|
[details-panel #f]
|
|
[showing-details #f]
|
|
[details-text "Details "]
|
|
[show-details-button-text (string-append details-text ">>")]
|
|
[hide-details-button-text (string-append details-text "<<")]
|
|
[hide-details
|
|
(lambda ()
|
|
(set! showing-details #f)
|
|
(send main-panel delete-child details-panel)
|
|
(send details-button set-label show-details-button-text)
|
|
(set! details-panel #f))]
|
|
[show-details
|
|
(lambda ()
|
|
(set! showing-details #t)
|
|
(send details-button set-label hide-details-button-text)
|
|
(set! details-button-callback hide-details)
|
|
(unless details-panel
|
|
(set! details-panel
|
|
(instantiate vertical-panel% ()
|
|
(parent main-panel)
|
|
(style '(border))
|
|
(border 2)
|
|
(vert-margin panel-sep)
|
|
(alignment '(left center))))
|
|
(for-each (lambda (d) (make-msg d details-panel))
|
|
details)))]
|
|
[details-button-callback
|
|
(lambda (e bv)
|
|
(if showing-details (hide-details) (show-details)))]
|
|
[buttons-panel (make-hpanel)]
|
|
[ok-button (instantiate button% ()
|
|
[label "OK"] [min-width 20] [parent buttons-panel]
|
|
[callback (lambda (b ev)
|
|
(send frame show #f)
|
|
(ok-thunk))])]
|
|
[spacer
|
|
(and details
|
|
(instantiate message% ()
|
|
[min-width 20] [label ""] [parent buttons-panel]))]
|
|
[details-button
|
|
(and details
|
|
(not (null? details))
|
|
(instantiate button% ()
|
|
[label show-details-button-text]
|
|
[min-width 20]
|
|
[parent buttons-panel]
|
|
[callback details-button-callback]))])
|
|
(send frame center)
|
|
(send frame show #t)))
|
|
|
|
(define (show-error-ok title caption)
|
|
(show-ok title
|
|
(list (format (string-constant vc-error-format) caption))
|
|
#f
|
|
void))
|
|
|
|
(define (make-wait-dialog parent title caption close-fun)
|
|
(let ([dialog (instantiate dialog% ()
|
|
[label title] [parent parent] [width 100] [height 50]
|
|
[stretchable-width #t] [stretchable-height #t])])
|
|
(instantiate message% () [label caption] [parent dialog])
|
|
(instantiate button% ()
|
|
[label (string-constant cancel)]
|
|
[parent dialog]
|
|
[callback (lambda (button ce) (close-fun) (send dialog show #f))])
|
|
dialog))
|
|
|
|
(define (show-wait-dialog dialog)
|
|
(send dialog center)
|
|
(thread (lambda () (send dialog show #t)))
|
|
(send dialog focus))
|
|
|
|
(define (hide-wait-dialog dialog)
|
|
(send dialog show #f)))))
|