diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss new file mode 100644 index 00000000..d7b2d4a0 --- /dev/null +++ b/collects/framework/guiutils.ss @@ -0,0 +1,155 @@ + + (unit/sig framework:gui-utils^ + (import) + + (define cursor-delay + (let ([x 0.25]) + (case-lambda + [() x] + [(v) (set! x v) x]))) + + (define show-busy-cursor + (lambda (thunk) + (local-busy-cursor #f thunk))) + + (define delay-action + (lambda (delay-time open close) + (let ([semaphore (make-semaphore 1)] + [open? #f] + [skip-it? #f]) + (thread + (lambda () + (sleep delay-time) + (semaphore-wait semaphore) + (unless skip-it? + (set! open? #t) + (open)) + (semaphore-post semaphore))) + (lambda () + (semaphore-wait semaphore) + (set! skip-it? #t) + (when open? + (close)) + (semaphore-post semaphore))))) + + (define local-busy-cursor + (let ([watch (make-object wx:cursor% wx:const-cursor-watch)]) + (opt-lambda (win thunk [delay (cursor-delay)]) + (let* ([old-cursor #f] + [cursor-off void]) + (dynamic-wind + (lambda () + (set! cursor-off + (delay-action + delay + (lambda () + (if win + (set! old-cursor (send win set-cursor watch)) + (wx:begin-busy-cursor))) + (lambda () + (if win + (send win set-cursor old-cursor) + (wx:end-busy-cursor)))))) + (lambda () (thunk)) + (lambda () (cursor-off))))))) + + (define unsaved-warning + (opt-lambda (filename action [can-save-now? #f]) + (let* ([result (void)] + [dialog% + (class dialog-box% () + (inherit show new-line fit tab center set-size) + (private + [on-dont-save + (lambda args + (set! result 'continue) + (show #f))] + [on-save-now + (lambda rags + (set! result 'save) + (show #f))] + [on-cancel + (lambda args + (set! result 'cancel) + (show #f))]) + (sequence + (super-init "Warning") + (let* ([panel (make-object vertical-panel% this)] + [msg + (make-object message% + (string-append "The file \"" + filename + "\" is not saved.") + panel)] + [button-panel + (make-object horizontal-panel% panel)]) + (make-object button% + (string-append action " Anyway") + button-panel + on-dont-save) + (let ([now (make-object button% + "Save" + button-panel + on-save-now)] + [cancel (make-object button% + "Cancel" + button-panel + on-cancel)]) + (if (not can-save-now?) + (begin (send cancel set-focus) + (send now show #f)) + (send now set-focus))) + (send msg center wx:const-horizontal)) + + (set-size -1 -1 10 10) + (center wx:const-both) + + (show #t)))]) + (make-object dialog%) + result))) + + (define read-snips/chars-from-buffer + (opt-lambda (edit [start 0] [end (send edit last-position)]) + (let ([pos start] + [box (box 0)]) + (lambda () + (let* ([snip (send edit find-snip pos + wx:const-snip-after-or-null box)] + [ans + (cond + [(<= end pos) eof] + [(null? snip) eof] + [(is-a? snip wx:text-snip%) + (let ([t (send snip get-text (- pos (unbox box)) 1)]) + (unless (= (string-length t) 1) + (error 'read-snips/chars-from-buffer + "unexpected string, t: ~s; pos: ~a box: ~a" + t pos box)) + (string-ref t 0))] + [else snip])]) + (set! pos (add1 pos)) + ans))))) + + (define open-input-buffer + (lambda (buffer) + (let ([pos 0]) + (make-input-port + (lambda () + (let ([c (send buffer get-character pos)]) + (if (char=? c #\null) + eof + (begin + (set! pos (add1 pos)) + c)))) + (lambda () + #t) + (lambda () + (void)))))) + + ; For use with wx:set-print-paper-name + (define print-paper-names + (list + "A4 210 x 297 mm" + "A3 297 x 420 mm" + "Letter 8 1/2 x 11 in" + "Legal 8 1/2 x 14 in")))