..
original commit: 024a1a90247703e7eb35512274fd31c0cae673ff
This commit is contained in:
Robby Findler
parent
55f5aa8dd3
commit
5a12fc1492
|
|
@ -11,6 +11,41 @@
|
|||
(syntax (provide/contract (name contract) ...))]))
|
||||
|
||||
(provide/contract/docs
|
||||
|
||||
(gui-utils:cancel-on-right?
|
||||
(-> boolean?)
|
||||
()
|
||||
"Returns \\scheme{#t} if cancel should be on the right-hand side (or below)"
|
||||
"in a dialog and \\scheme{#f} otherwise."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:ok/cancel-buttons %"
|
||||
".")
|
||||
(gui-utils:ok/cancel-buttons
|
||||
(opt->*
|
||||
((is-a?/c area-container<%>)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any)
|
||||
((is-a?/c button%) (is-a?/c event%) . -> . any))
|
||||
(string?
|
||||
string?)
|
||||
((is-a?/c button%)
|
||||
(is-a?/c button%)))
|
||||
((parent
|
||||
confirm-callback
|
||||
cancel-callback)
|
||||
((confirm-label (string-constant ok))
|
||||
(cancel-label (string-constant cancel))))
|
||||
"Adds an Ok and a cancel button to a panel, changing the order"
|
||||
"to suit the platform. Under MacOS and unix, the confirmation action"
|
||||
"is on the right (or bottom) and under Windows, the canceling action is on the"
|
||||
"right (or bottom)."
|
||||
"The confirmation action button has the \\scheme|'(border)| style."
|
||||
"The buttons are also sized to be the same width."
|
||||
""
|
||||
"See also"
|
||||
"@flink gui-utils:cancel-on-right? %"
|
||||
".")
|
||||
|
||||
(gui-utils:next-untitled-name
|
||||
(-> string?)
|
||||
()
|
||||
|
|
@ -142,9 +177,12 @@
|
|||
"The argument \\var{default-result} determines how closing the window is"
|
||||
"treated. If the argument is \rawscm{'disallow-close}, closing the window"
|
||||
"is not allowed. If it is anything else, that value is returned when"
|
||||
"the user closes the window.")
|
||||
|
||||
;; (gui-utils:open-input-buffer any?) ;; who uses this?!?!
|
||||
"the user closes the window."
|
||||
""
|
||||
"If "
|
||||
"@flink gui-utils:cancel-on-right?"
|
||||
"returns \\scheme|#t|, the false choice is on the right."
|
||||
"Otherwise, the true choice is on the right.")
|
||||
|
||||
(gui-utils:get-clicked-clickback-delta
|
||||
(-> (is-a?/c style-delta%))
|
||||
|
|
@ -172,6 +210,38 @@
|
|||
"@flink gui-utils:get-clicked-clickback-delta %"
|
||||
"."))
|
||||
|
||||
(define (cancel-on-right?) (eq? (system-type) 'windows))
|
||||
|
||||
(define ok/cancel-buttons
|
||||
(opt-lambda (parent
|
||||
confirm-callback
|
||||
cancel-callback
|
||||
[confirm-str (string-constant ok)]
|
||||
[cancel-str (string-constant cancel)])
|
||||
(let ([confirm (lambda ()
|
||||
(instantiate button% ()
|
||||
(parent parent)
|
||||
(callback confirm-callback)
|
||||
(label confirm-str)
|
||||
(style '(border))))]
|
||||
[cancel (lambda ()
|
||||
(instantiate button% ()
|
||||
(parent parent)
|
||||
(callback cancel-callback)
|
||||
(label cancel-str)))])
|
||||
(let-values ([(b1 b2)
|
||||
(cond
|
||||
[(cancel-on-right?)
|
||||
(values (confirm) (cancel))]
|
||||
[else
|
||||
(values (cancel) (confirm))])])
|
||||
(let ([w (max (send b1 get-width)
|
||||
(send b2 get-width))])
|
||||
(send b1 min-width w)
|
||||
(send b2 min-width w)
|
||||
(values b1 b2))))))
|
||||
|
||||
|
||||
(define clickback-delta (make-object style-delta% 'change-underline #t))
|
||||
(send clickback-delta set-delta-foreground "BLUE")
|
||||
(define (get-clickback-delta) clickback-delta)
|
||||
|
|
@ -243,63 +313,64 @@
|
|||
(lambda () (cursor-off))))])))
|
||||
|
||||
(define unsaved-warning
|
||||
(case-lambda
|
||||
[(filename action-anyway) (unsaved-warning filename action-anyway #f)]
|
||||
[(filename action-anyway can-save-now?) (unsaved-warning filename action-anyway can-save-now? #f)]
|
||||
[(filename action-anyway can-save-now? parent)
|
||||
(let* ([result (void)]
|
||||
[unsaved-dialog%
|
||||
(class dialog%
|
||||
(inherit show center)
|
||||
|
||||
(define/private (on-dont-save)
|
||||
(set! result 'continue)
|
||||
(show #f))
|
||||
(define/private (on-save-now)
|
||||
(set! result 'save)
|
||||
(show #f))
|
||||
(define/private (on-cancel)
|
||||
(set! result 'cancel)
|
||||
(show #f))
|
||||
|
||||
(super-make-object (string-constant warning) parent)
|
||||
|
||||
(let* ([panel (make-object vertical-panel% this)]
|
||||
[msg
|
||||
(make-object message%
|
||||
(format (string-constant file-is-not-saved) filename)
|
||||
panel)]
|
||||
[button-panel
|
||||
(make-object horizontal-panel% panel)])
|
||||
(make-object button%
|
||||
(string-append action-anyway)
|
||||
button-panel
|
||||
(lambda (x y) (on-dont-save)))
|
||||
|
||||
(let ([now (make-object button%
|
||||
(string-constant save)
|
||||
button-panel
|
||||
(lambda (x y) (on-save-now))
|
||||
(if can-save-now?
|
||||
'(border)
|
||||
'()))]
|
||||
[cancel (make-object button%
|
||||
(string-constant cancel)
|
||||
button-panel
|
||||
(lambda (x y) (on-cancel))
|
||||
(if can-save-now?
|
||||
'()
|
||||
'(border)))])
|
||||
(if can-save-now?
|
||||
(send now focus)
|
||||
(begin (send cancel focus)
|
||||
(send now show #f))))
|
||||
|
||||
(center 'both)
|
||||
|
||||
(show #t)))])
|
||||
(make-object unsaved-dialog%)
|
||||
result)]))
|
||||
(opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))
|
||||
(let* ([result (void)]
|
||||
[unsaved-dialog%
|
||||
(class dialog%
|
||||
(inherit show center)
|
||||
|
||||
(define/private (on-dont-save)
|
||||
(set! result 'continue)
|
||||
(show #f))
|
||||
(define/private (on-save-now)
|
||||
(set! result 'save)
|
||||
(show #f))
|
||||
(define/private (on-cancel)
|
||||
(set! result 'cancel)
|
||||
(show #f))
|
||||
|
||||
(super-make-object (string-constant warning) parent)
|
||||
|
||||
(let* ([panel (make-object vertical-panel% this)]
|
||||
[msg
|
||||
(make-object message%
|
||||
(format (string-constant file-is-not-saved) filename)
|
||||
panel)]
|
||||
[button-panel
|
||||
(make-object horizontal-panel% panel)]
|
||||
[anyway (make-object button%
|
||||
(string-append action-anyway)
|
||||
button-panel
|
||||
(lambda (x y) (on-dont-save)))]
|
||||
[now (make-object button%
|
||||
(string-constant save)
|
||||
button-panel
|
||||
(lambda (x y) (on-save-now))
|
||||
(if can-save-now?
|
||||
'(border)
|
||||
'()))]
|
||||
[cancel (make-object button%
|
||||
(string-constant cancel)
|
||||
button-panel
|
||||
(lambda (x y) (on-cancel))
|
||||
(if can-save-now?
|
||||
'()
|
||||
'(border)))])
|
||||
(send button-panel change-children
|
||||
(lambda (l)
|
||||
(if (cancel-on-right?)
|
||||
(list anyway now cancel)
|
||||
(list anyway cancel now))))
|
||||
(if can-save-now?
|
||||
(send now focus)
|
||||
(begin (send cancel focus)
|
||||
(send now show #f)))
|
||||
|
||||
(center 'both)
|
||||
|
||||
(show #t)))])
|
||||
(make-object unsaved-dialog%)
|
||||
result)))
|
||||
|
||||
(define get-choice
|
||||
(opt-lambda (message
|
||||
|
|
@ -356,41 +427,20 @@
|
|||
|
||||
(send vp set-alignment 'left 'center)
|
||||
(send hp set-alignment 'right 'center)
|
||||
(send (make-object button% true-choice hp on-true '(border)) focus)
|
||||
(make-object button% false-choice hp on-false)
|
||||
(let ([make-true
|
||||
(lambda ()
|
||||
(send (make-object button% true-choice hp on-true '(border)) focus))]
|
||||
[make-false
|
||||
(lambda ()
|
||||
(make-object button% false-choice hp on-false))])
|
||||
(if (cancel-on-right?)
|
||||
(begin (make-true) (make-false))
|
||||
(begin (make-false) (make-true))))
|
||||
(send hp stretchable-height #f)
|
||||
(send dialog center 'both)
|
||||
(send dialog show #t)
|
||||
result)))
|
||||
|
||||
(define open-input-buffer
|
||||
(lambda (buffer)
|
||||
(let ([pos 0]
|
||||
[lock (make-semaphore 1)])
|
||||
(make-custom-input-port
|
||||
lock
|
||||
(lambda (s)
|
||||
(if (semaphore-try-wait? lock)
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let* ([len (send buffer last-position)]
|
||||
[count (min (string-length s)
|
||||
(- len pos))])
|
||||
(if (zero? count)
|
||||
eof
|
||||
(let ([got (send buffer get-text pos (+ pos count))])
|
||||
(let loop ([count count])
|
||||
(unless (zero? count)
|
||||
(let ([count (sub1 count)])
|
||||
(string-set! s count (string-ref got count))
|
||||
(loop (sub1 count)))))
|
||||
(set! pos (+ pos count))
|
||||
count))))
|
||||
(lambda () (semaphore-post lock)))
|
||||
0))
|
||||
#f
|
||||
void))))
|
||||
|
||||
|
||||
;; manual renaming
|
||||
(define gui-utils:next-untitled-name next-untitled-name)
|
||||
|
|
@ -399,6 +449,7 @@
|
|||
(define gui-utils:local-busy-cursor local-busy-cursor)
|
||||
(define gui-utils:unsaved-warning unsaved-warning)
|
||||
(define gui-utils:get-choice get-choice)
|
||||
(define gui-utils:open-input-buffer open-input-buffer)
|
||||
(define gui-utils:get-clicked-clickback-delta get-clicked-clickback-delta)
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta))
|
||||
(define gui-utils:get-clickback-delta get-clickback-delta)
|
||||
(define gui-utils:ok/cancel-buttons ok/cancel-buttons)
|
||||
(define gui-utils:cancel-on-right? cancel-on-right?))
|
||||
|
|
@ -95,8 +95,6 @@
|
|||
|
||||
(make-object c% (string-constant insert-text-box-item)
|
||||
edit-menu (edit-menu:do 'insert-text-box) #f #f on-demand)
|
||||
(make-object c% (string-constant insert-pb-box-item)
|
||||
edit-menu (edit-menu:do 'insert-pasteboard-box) #f #f on-demand)
|
||||
(make-object c% (string-constant insert-image-item)
|
||||
edit-menu (edit-menu:do 'insert-image) #f #f on-demand)
|
||||
(void)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
|
||||
(module group mzscheme
|
||||
(require (lib "string-constant.ss" "string-constants")
|
||||
(lib "unitsig.ss")
|
||||
|
|
@ -298,59 +299,54 @@
|
|||
(super-instantiate ())))
|
||||
|
||||
(define (choose-a-frame parent)
|
||||
(letrec ([sorted-frames
|
||||
(quicksort
|
||||
(send (get-the-frame-group) get-frames)
|
||||
(lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
|
||||
[d (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
|
||||
[lb (instantiate list-box% ()
|
||||
(label #f)
|
||||
(choices (map (lambda (x) (send x get-label)) sorted-frames))
|
||||
(callback (lambda (x y) (listbox-callback y)))
|
||||
(parent d))]
|
||||
[t (instantiate text:hide-caret/selection% ())]
|
||||
[ec (instantiate canvas:basic% ()
|
||||
(parent d)
|
||||
(stretchable-height #f))]
|
||||
[bp (instantiate horizontal-panel% ()
|
||||
(parent d)
|
||||
(stretchable-height #f)
|
||||
(alignment '(right center)))]
|
||||
[cancelled? #t]
|
||||
[ok (instantiate button% ()
|
||||
(label (string-constant ok))
|
||||
(parent bp)
|
||||
(callback (lambda (x y)
|
||||
(set! cancelled? #f)
|
||||
(send d show #f)))
|
||||
(style '(border)))]
|
||||
[cancel (instantiate button% ()
|
||||
(label (string-constant cancel))
|
||||
(parent bp)
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(send d show #f))))]
|
||||
[listbox-callback
|
||||
(lambda (evt)
|
||||
(case (send evt get-event-type)
|
||||
[(list-box)
|
||||
|
||||
(send ok enable (pair? (send lb get-selections)))
|
||||
|
||||
(let ([full-name
|
||||
(let ([sels (send lb get-selections)])
|
||||
(and (pair? sels)
|
||||
(let ([fr (list-ref sorted-frames (car sels))])
|
||||
(and (is-a? fr frame:basic%)
|
||||
(send fr get-filename)))))])
|
||||
(send t begin-edit-sequence)
|
||||
(send t erase)
|
||||
(when full-name
|
||||
(send t insert full-name))
|
||||
(send t end-edit-sequence))]
|
||||
[(list-box-dclick)
|
||||
(set! cancelled? #f)
|
||||
(send d show #f)]))])
|
||||
(letrec-values ([(sorted-frames)
|
||||
(quicksort
|
||||
(send (get-the-frame-group) get-frames)
|
||||
(lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
|
||||
[(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
|
||||
[(lb) (instantiate list-box% ()
|
||||
(label #f)
|
||||
(choices (map (lambda (x) (send x get-label)) sorted-frames))
|
||||
(callback (lambda (x y) (listbox-callback y)))
|
||||
(parent d))]
|
||||
[(t) (instantiate text:hide-caret/selection% ())]
|
||||
[(ec) (instantiate canvas:basic% ()
|
||||
(parent d)
|
||||
(stretchable-height #f))]
|
||||
[(bp) (instantiate horizontal-panel% ()
|
||||
(parent d)
|
||||
(stretchable-height #f)
|
||||
(alignment '(right center)))]
|
||||
[(cancelled?) #t]
|
||||
[(listbox-callback)
|
||||
(lambda (evt)
|
||||
(case (send evt get-event-type)
|
||||
[(list-box)
|
||||
|
||||
(send ok enable (pair? (send lb get-selections)))
|
||||
|
||||
(let ([full-name
|
||||
(let ([sels (send lb get-selections)])
|
||||
(and (pair? sels)
|
||||
(let ([fr (list-ref sorted-frames (car sels))])
|
||||
(and (is-a? fr frame:basic%)
|
||||
(send fr get-filename)))))])
|
||||
(send t begin-edit-sequence)
|
||||
(send t erase)
|
||||
(when full-name
|
||||
(send t insert full-name))
|
||||
(send t end-edit-sequence))]
|
||||
[(list-box-dclick)
|
||||
(set! cancelled? #f)
|
||||
(send d show #f)]))]
|
||||
[(ok cancel)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
bp
|
||||
(lambda (x y)
|
||||
(set! cancelled? #f)
|
||||
(send d show #f))
|
||||
(lambda (x y)
|
||||
(send d show #f)))])
|
||||
(send ec set-line-count 3)
|
||||
(send ec set-editor t)
|
||||
(send t auto-wrap #t)
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
[group : framework:group^])
|
||||
|
||||
;; preferences
|
||||
(preferences:set-default 'framework:last-url-string "" string?)
|
||||
(preferences:set-default 'framework:recently-opened-sort-by 'age
|
||||
(lambda (x) (or (eq? x 'age) (eq? x 'name))))
|
||||
(preferences:set-default 'framework:recent-items-window-w 400 number?)
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
(lib "file.ss")
|
||||
(lib "class100.ss")
|
||||
"sig.ss"
|
||||
"../gui-utils.ss"
|
||||
(lib "mred-sig.ss" "mred")
|
||||
(lib "pretty.ss")
|
||||
(lib "list.ss"))
|
||||
|
|
@ -731,15 +732,14 @@
|
|||
[ok-callback (lambda args
|
||||
(save)
|
||||
(hide-dialog))]
|
||||
[ok-button (make-object button% (string-constant ok)
|
||||
bottom-panel ok-callback '(border))]
|
||||
[cancel-callback (lambda (_1 _2)
|
||||
(hide-dialog)
|
||||
(install-stashed-preferences stashed-prefs))]
|
||||
[cancel-button (make-object button% (string-constant cancel)
|
||||
bottom-panel cancel-callback)]
|
||||
[grow-box-space (make-object grow-box-spacer-pane% bottom-panel)])
|
||||
(send ok-button min-width (send cancel-button get-width))
|
||||
(install-stashed-preferences stashed-prefs))])
|
||||
(gui-utils:ok/cancel-buttons
|
||||
bottom-panel
|
||||
cancel-callback
|
||||
ok-callback)
|
||||
(make-object grow-box-spacer-pane% bottom-panel)
|
||||
(send* bottom-panel
|
||||
(stretchable-height #f)
|
||||
(set-alignment 'right 'center))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
|
||||
(module framework-test-engine mzscheme
|
||||
(require (lib "pconvert.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user