suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: b6e33a3b3ec4d6edb98c90c7fbd34dc70967891b
This commit is contained in:
Robby Findler 2002-05-02 19:39:58 +00:00
parent 163d81c907
commit a265ad934c
11 changed files with 1253 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/framework/framework.ss
View File

@ -1,13 +1,11 @@
(module framework mzscheme
(require (lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "mred-sig.ss" "mred")
"test.ss"
"test-sig.ss"
"gui-utils.ss"
"gui-utils-sig.ss"
"framework-unit.ss"
"framework-sig.ss"
@ -16,11 +14,11 @@
"specs.ss")
(provide-signature-elements framework-class^)
(provide-signature-elements ((unit test : framework:test^)
(unit gui-utils : framework:gui-utils^)))
(provide (all-from "macro.ss"))
(provide (all-from "specs.ss"))
(provide (all-from "macro.ss")
(all-from "specs.ss")
(all-from "test.ss")
(all-from "gui-utils.ss"))
(provide exn:struct:unknown-preference
exn:struct:exn)
@ -298,7 +296,7 @@
"Generates a name for an backup file from \\var{filename}.")
(finder:dialog-parent-parameter
(case->
((union false? (is-a?/c top-level-window<%>)) . -> . void)
((union false? (is-a?/c top-level-window<%>)) . -> . void?)
(-> (union false? (is-a?/c top-level-window<%>))))
((parent) ())
"This is a parameter (see "
@ -332,7 +330,7 @@
"Its default value is \\rawscm{\"\"}.")
(finder:default-filters
(case->
((listof (list/p string? string?)) . -> . void)
((listof (list/p string? string?)) . -> . void?)
(-> (listof (list/p string? string?))))
((filters) ())
"This parameter controls the default extension for the framework's "
@ -606,7 +604,7 @@
"If \\var{filename} is \\rawscm{\\#f}, \\var{make-default} is used."
"\\end{itemize}")
(handler:open-file
(-> (is-a?/c frame:basic<%>))
(-> (union false? (is-a?/c frame:basic<%>)))
()
"This function queries the user for a filename and opens the file for"
"editing. It uses "
@ -724,8 +722,8 @@
(keymap:add-to-right-button-menu
(case->
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void) . -> . void)
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void)))
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?)
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
((func) ())
"When the keymap that "
"@flink keymap:get-global"
@ -741,6 +739,27 @@
"@flink keymap:add-to-right-button-menu/before %"
".")
(keymap:add-to-right-button-menu/before
(case->
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)
. -> .
void?)
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
((func) ())
"When the keymap that "
"@flink keymap:get-global"
"returns is installed into an editor, this function is called"
"for right button clicks. "
""
"After calling this procedure, the "
"function"
"@flink append-editor-operation-menu-items"
"is called."
""
"See also"
"@flink keymap:add-to-right-button-menu %"
".")
(keymap:call/text-keymap-initializer
((-> any?) . -> . any?)
(thunk-proc)
@ -1003,27 +1022,6 @@
"@link keymap"
"with the bindings for searching.")
(keymap:add-to-right-button-menu/before
(case->
(((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)
. -> .
void?)
(-> ((is-a?/c menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?)))
((func) ())
"When the keymap that "
"@flink keymap:get-global"
"returns is installed into an editor, this function is called"
"for right button clicks. "
""
"After calling this procedure, the "
"function"
"@flink append-editor-operation-menu-items"
"is called."
""
"See also"
"@flink keymap:add-to-right-button-menu %"
".")
(scheme-paren:backward-containing-sexp
(opt->
((is-a?/c text%)
@ -1292,10 +1290,8 @@
"Extracts the z component of \\var{xyz}."))
(define-values/invoke-unit/sig
frameworkc^
frameworkc@
framework^
framework@
#f
mred^
(test : framework:test^)
(gui-utils : framework:gui-utils^)))
mred^))

381
collects/framework/gui-utils.ss
View File

@ -1,17 +1,366 @@
(module gui-utils mzscheme
(require (lib "unitsig.ss")
"gui-utils-sig.ss"
"gui-utils-unit.ss"
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred"))
(provide-signature-elements ((unit gui-utils : framework:gui-utils^)))
(define-values/invoke-unit/sig
((unit gui-utils : framework:gui-utils^))
(compound-unit/sig
(import [mred : mred^])
(link [gui-utils : framework:gui-utils^ (framework:gui-utils@ mred)])
(export (unit gui-utils)))
#f
mred^))
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
"specs.ss"
(lib "string-constant.ss" "string-constants"))
(define-syntax (provide/contract/docs stx)
(syntax-case stx ()
[(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))]))
(provide/contract/docs
(gui-utils:next-untitled-name any?)
(gui-utils:cursor-delay any?)
(gui-utils:show-busy-cursor any?)
(gui-utils:delay-action any?)
(gui-utils:local-busy-cursor any?)
(gui-utils:unsaved-warning any?)
(gui-utils:read-snips/chars-from-text any?)
(gui-utils:get-choice any?)
(gui-utils:open-input-buffer any?)
(gui-utils:get-clicked-clickback-delta any?)
(gui-utils:get-clickback-delta any?))
(provide (rename alphabetic-list-box% gui-utils:alphabetic-list-box%)
(rename text-snip<%> gui-utils:text-snip<%>))
(define clickback-delta (make-object style-delta% 'change-underline #t))
(send clickback-delta set-delta-foreground "BLUE")
(define (get-clickback-delta) clickback-delta)
(define clicked-clickback-delta (make-object style-delta%))
(send clicked-clickback-delta set-delta-background "BLACK")
(define (get-clicked-clickback-delta) clicked-clickback-delta)
(define next-untitled-name
(let ([n 1])
(lambda ()
(begin0
(cond
[(= n 1) (string-constant untitled)]
[else (format (string-constant untitled-n) n)])
(set! n (+ n 1))))))
(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 cursor% 'watch)])
(case-lambda
[(win thunk) (local-busy-cursor win thunk (cursor-delay))]
[(win thunk delay)
(let* ([old-cursor #f]
[cursor-off void])
(dynamic-wind
(lambda ()
(set! cursor-off
(delay-action
delay
(lambda ()
(if win
(begin (set! old-cursor (send win get-cursor))
(send win set-cursor watch))
(begin-busy-cursor)))
(lambda ()
(if win
(send win set-cursor old-cursor)
(end-busy-cursor))))))
(lambda () (thunk))
(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)]))
(define get-choice
(opt-lambda (message
true-choice
false-choice
(title (string-constant warning))
(default-result 'disallow-close)
(parent #f))
(letrec ([result default-result]
[dialog (make-object
(class dialog%
(rename [super-on-close on-close]
[super-can-close? can-close?])
(define/override (can-close?)
(cond
[(eq? default-result 'disallow-close)
(bell)
(message-box title
(format (string-constant please-choose-either)
true-choice false-choice))
#f]
[else
(super-can-close?)]))
(define/override (on-close)
(set! result default-result)
(super-on-close))
(super-make-object title parent)))]
[on-true
(lambda args
(set! result #t)
(send dialog show #f))]
[on-false
(lambda rags
(set! result #f)
(send dialog show #f))]
[vp (make-object vertical-panel% dialog)]
[hp (make-object horizontal-panel% dialog)])
(if ((string-length message) . < . 200)
(let loop ([m message])
(let ([match (regexp-match (format "^([^~n]*)~n(.*)")
m)])
(if match
(begin (make-object message% (cadr match) vp)
(loop (caddr match)))
(make-object message% m vp))))
(let* ([t (make-object text%)]
[ec (make-object editor-canvas% vp t)])
(send ec min-width 400)
(send ec min-height 200)
(send t insert message)
(send t auto-wrap #t)
(send t lock #t)))
(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)
(send hp stretchable-height #f)
(send dialog center 'both)
(send dialog show #t)
result)))
(define text-snip<%> (interface () get-string))
(define read-snips/chars-from-text
(letrec ([get-snips
(lambda (text start end)
(let* ([pos-box (box 0)]
[snip (send text find-snip start 'after-or-none pos-box)])
(cond
[(not snip) null]
[(> (+ (unbox pos-box) (send snip get-count)) end) null]
[else (cons snip (get-snips text (+ start (send snip get-count)) end))])))])
(case-lambda
[(text) (read-snips/chars-from-text text 0)]
[(text start) (read-snips/chars-from-text text start (send text last-position))]
[(text start end)
(define pos-box (box 0))
(define (get-next)
(send text split-snip start)
(send text split-snip end)
;; must get all of the snips out of the buffer before reading -- they may change.
(let loop ([snips (get-snips text start end)])
(cond
[(null? snips)
(set! get-next (lambda () eof))
eof]
[(or (is-a? (car snips) string-snip%)
(is-a? (car snips) text-snip<%>))
(let ([str (if (is-a? (car snips) text-snip<%>)
(send (car snips) get-string)
(send (car snips) get-text 0 (send (car snips) get-count)))])
(let string-loop ([n 0])
(cond
[(< n (string-length str))
(set! get-next (lambda () (string-loop (+ n 1))))
(string-ref str n)]
[else
(loop (cdr snips))])))]
[else
(set! get-next (lambda () (loop (cdr snips))))
(car snips)])))
(let ([read-snips/chars-from-text-thunk
(lambda ()
(get-next))])
read-snips/chars-from-text-thunk)])))
(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))))
(define repeated-keystroke-timeout 300)
(define alphabetic-list-box%
(class list-box%
(init-field choices callback)
(field (chars null)
(last-time-stamp #f))
(rename [super-on-subwindow-event on-subwindow-event]
[super-on-subwindow-char on-subwindow-char])
(define/override (on-subwindow-event receiver evt)
(set! chars null)
(super-on-subwindow-event receiver evt))
(define/override (on-subwindow-char receiver evt)
(let ([code (send evt get-key-code)])
(when (or (not (char? code))
(and last-time-stamp
((- (send evt get-time-stamp) last-time-stamp)
. >= .
repeated-keystroke-timeout)))
(set! chars null))
(set! last-time-stamp (send evt get-time-stamp))
(cond
[(and (char? code) (or (char-alphabetic? code) (char-numeric? code)))
(set! chars (cons code chars))
(scroll-to-matching)
(callback this (instantiate control-event% ()
(event-type 'list-box)
(time-stamp (send evt get-time-stamp))))]
[else
(set! chars null)
(super-on-subwindow-char receiver evt)])))
;; scroll-to-matching : -> void
;; scrolls the list box to the first string
;; that matches the typed chars in `chars'.
(define (scroll-to-matching)
(let* ([typed-str (apply string (reverse chars))]
[typed-len (string-length typed-str)])
(let loop ([n 0])
(when (< n (get-number))
(let ([str (get-string n)])
(cond
[(and ((string-length str) . >= . typed-len)
(string=? typed-str (substring str 0 typed-len)))
(set-selection n)
(make-visible n)]
[else (loop (+ n 1))]))))))
(inherit get-number get-string set-selection)
;; make-visible : number -> void
;; scrolls the list box so that the nth item is visible,
;; unless the n'th item is already visible, in which case
;; it does nothing.
(define (make-visible n)
(set-first-visible-item n))
(inherit set-first-visible-item)
(super-instantiate ()
(choices choices)
(callback callback))))
;; manual renaming
(define gui-utils:next-untitled-name next-untitled-name)
(define gui-utils:show-busy-cursor show-busy-cursor)
(define gui-utils:delay-action delay-action)
(define gui-utils:local-busy-cursor local-busy-cursor)
(define gui-utils:unsaved-warning unsaved-warning)
(define gui-utils:read-snips/chars-from-text read-snips/chars-from-text)
(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:text-snip<%> text-snip<%>))

3
collects/framework/private/editor.ss
View File

@ -4,7 +4,7 @@
(lib "class100.ss")
(lib "string-constant.ss" "string-constants")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
"../macro.ss"
(lib "etc.ss")
(lib "mred-sig.ss" "mred")
@ -24,7 +24,6 @@
[text : framework:text^]
[pasteboard : framework:pasteboard^]
[frame : framework:frame^]
[gui-utils : framework:gui-utils^]
[handler : framework:handler^])
(rename [-keymap<%> keymap<%>])

5
collects/framework/private/exit.ss
View File

@ -3,7 +3,7 @@
(lib "string-constant.ss" "string-constants")
(lib "class.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss")
(lib "etc.ss"))
@ -13,8 +13,7 @@
(define exit@
(unit/sig framework:exit^
(import mred^
[preferences : framework:preferences^]
[gui-utils : framework:gui-utils^])
[preferences : framework:preferences^])
(rename (-exit exit))
(define frame-exiting (make-parameter #f))

3
collects/framework/private/finder.ss
View File

@ -3,7 +3,7 @@
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
(lib "class100.ss")
(lib "class.ss")
(lib "mred-sig.ss" "mred")
@ -18,7 +18,6 @@
(unit/sig framework:finder^
(import mred^
[preferences : framework:preferences^]
[gui-utils : framework:gui-utils^]
[keymap : framework:keymap^])
(rename [-put-file put-file]

3
collects/framework/private/frame.ss
View File

@ -6,7 +6,7 @@
(lib "class100.ss")
(lib "include.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
"../macro.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
@ -24,7 +24,6 @@
[handler : framework:handler^]
[application : framework:application^]
[panel : framework:panel^]
[gui-utils : framework:gui-utils^]
[exit : framework:exit^]
[finder : framework:finder^]
[keymap : framework:keymap^]

3
collects/framework/private/group.ss
View File

@ -3,7 +3,7 @@
(lib "unitsig.ss")
(lib "class.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "file.ss"))
@ -16,7 +16,6 @@
[application : framework:application^]
[frame : framework:frame^]
[preferences : framework:preferences^]
[gui-utils : framework:gui-utils^]
[text : framework:text^]
[canvas : framework:canvas^]
[menu : framework:menu^])

3
collects/framework/private/handler.ss
View File

@ -5,7 +5,7 @@
(lib "class100.ss")
(lib "list.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss"))
@ -14,7 +14,6 @@
(define handler@
(unit/sig framework:handler^
(import mred^
[gui-utils : framework:gui-utils^]
[finder : framework:finder^]
[group : framework:group^]
[text : framework:text^]

5
collects/framework/private/main.ss
View File

@ -2,7 +2,7 @@
(require (lib "unitsig.ss")
(lib "class.ss")
"sig.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
"../macro.ss"
(lib "string-constant.ss" "string-constants")
(lib "mred-sig.ss" "mred"))
@ -14,8 +14,7 @@
(import mred^
[preferences : framework:preferences^]
[exit : framework:exit^]
[group : framework:group^]
[gui-utils : framework:gui-utils^])
[group : framework:group^])
;; preferences

3
collects/framework/private/text.ss
View File

@ -6,7 +6,7 @@
(lib "class100.ss")
"sig.ss"
"../macro.ss"
"../gui-utils-sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "etc.ss"))
@ -19,7 +19,6 @@
[editor : framework:editor^]
[preferences : framework:preferences^]
[keymap : framework:keymap^]
[gui-utils : framework:gui-utils^]
[color-model : framework:color-model^]
[frame : framework:frame^]
[scheme : framework:scheme^])

856
collects/framework/test.ss
View File

@ -1,16 +1,846 @@
(module test mzscheme
(require (lib "unitsig.ss")
"test-sig.ss"
"test-unit.ss"
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred"))
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "etc.ss")
"specs.ss")
(define-syntax (provide/contract/docs stx)
(syntax-case stx ()
[(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))]))
(provide/contract/docs
(test:run-interval any?)
(test:reraise-error any?)
(test:run-one any?)
(test:current-get-eventspaces any?)
(test:close-top-level-window any?)
;; (frame-has? f p) =
;; f is a frame and it has a child (in it or a subpanel) that responds #t to p
(test:button-push any?)
#|
((union (lambda (str)
(and (string? str)
(frame-has? (get-top-level-focus-window)
(lambda (x)
(and (is-a? x button%)
(string=? (send x get-label) str)
(send x is-enabled?)
(send x is-shown?))))))
(lambda (btn)
(and (is-a? btn button%)
(frame-has? (get-top-level-focus-window)
(lambda (x)
(and (eq? x btn)
(send x is-enabled?)
(send x is-shown?)))))))
->
void)
|#
(test:set-radio-box! any?)
(test:set-radio-box-item! any?)
(test:set-check-box! any?)
(test:set-choice! any?)
(test:keystroke any?)
(test:menu-select any?)
(test:mouse-click any?)
(test:new-window any?))
(define initial-run-interval 0) ;; milliseconds
(provide-signature-elements ((unit test : framework:test^)))
;;
;; The minimum time an action is allowed to run before returning from
;; mred:test:action. Controls the rate at which actions are started,
;; and gives some slack time for real events to complete (eg, update).
;; Make-parameter doesn't do what we need across threads.
;; Probably don't need semaphores here (set! is atomic).
;; Units are in milliseconds (as in mred:timer%).
;;
(define run-interval
(let ([tag 'test:run-interval]
[msec initial-run-interval])
(case-lambda
[() msec]
[(x) (if (and (integer? x) (exact? x) (<= 0 x))
(set! msec x)
(error tag "expects exact, non-negative integer, given: ~e" x))])))
;;
;; How we get into the handler thread, and put fake actions
;; on the real event queue.
;;
(define timer-callback%
(class timer%
(init-field thunk)
(define/override (notify) (thunk))
(super-instantiate ())))
(define install-timer
(lambda (msec thunk)
(let ([timer (make-object timer-callback% thunk)])
(send timer start msec #t))))
;;
;; Simple accounting of actions and errors.
;;
;; Keep number of unfinished actions. An error in the buffer
;; (caught but not-yet-reraised) counts as an unfinished action.
;; (but kept in the-error, not count).
;;
;; Keep buffer of one error, and reraise at first opportunity.
;; Keep just first error, any others are thrown on the floor.
;; Reraising the error flushes the buffer.
;; Store exn in box, so can correctly catch (raise #f).
;;
;; These values are set in handler thread and read in main thread,
;; so certainly need semaphores here.
;;
(define-values (begin-action end-action end-action-with-error
get-exn-box is-exn? num-actions)
(let
([sem (make-semaphore 1)]
[count 0] ;; number unfinished actions.
[the-error #f]) ;; boxed exn struct, or else #f.
(letrec
([begin-action
(lambda ()
(semaphore-wait sem)
(set! count (add1 count))
(semaphore-post sem))]
[end-action
(lambda ()
(semaphore-wait sem)
(set! count (sub1 count))
(semaphore-post sem))]
[end-action-with-error
(lambda (exn)
(semaphore-wait sem)
(set! count (sub1 count))
(unless the-error
(set! the-error (box exn)))
(semaphore-post sem))]
[get-exn-box
(lambda ()
(semaphore-wait sem)
(let ([ans the-error])
(set! the-error #f)
(semaphore-post sem)
ans))]
[is-exn?
(lambda ()
(semaphore-wait sem)
(let ([ans (if the-error #t #f)])
(semaphore-post sem)
ans))]
[num-actions
(lambda ()
(semaphore-wait sem)
(let ([ans (+ count (if the-error 1 0))])
(semaphore-post sem)
ans))])
(values begin-action end-action end-action-with-error
get-exn-box is-exn? num-actions))))
;; Functions to export, always in main thread.
(define number-pending-actions num-actions)
(define reraise-error
(lambda ()
(let ([exn-box (get-exn-box)])
(if exn-box (raise (unbox exn-box)) (void)))))
;;
;; Start running thunk in handler thread.
;; Don't return until run-interval expires, and thunk finishes,
;; raises error, or yields (ie, at event boundary).
;; Reraise error (if exists) even from previous action.
;; Note: never more than one timer (of ours) on real event queue.
;;
(define run-one
(let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)])
(thread
(rec loop
(lambda ()
(semaphore-wait thread-semaphore)
(sleep)
(semaphore-post yield-semaphore)
(loop))))
(lambda (thunk)
(let ([sem (make-semaphore 0)])
(letrec
([start
(lambda ()
(define-values/invoke-unit/sig ((unit test : framework:test^))
(compound-unit/sig
(import [m : mred^])
(link [test : framework:test^ (framework:test@ m)])
(export (unit test)))
#f
mred^))
;; guarantee (probably) that some events are handled
(semaphore-post thread-semaphore)
(yield yield-semaphore)
(install-timer (run-interval) return)
(unless (is-exn?)
(begin-action)
(pass-errors-out thunk)
(end-action)))]
[pass-errors-out
(lambda (thunk)
(parameterize ([current-exception-handler
(lambda (exn)
(end-action-with-error exn)
((error-escape-handler)))])
(thunk)))]
[return (lambda () (semaphore-post sem))])
(install-timer 0 start)
(semaphore-wait sem)
(reraise-error))))))
(define current-get-eventspaces
(make-parameter (lambda () (list (current-eventspace)))))
(define (get-active-frame)
(ormap (lambda (eventspace)
(parameterize ([current-eventspace eventspace])
(get-top-level-focus-window)))
((current-get-eventspaces))))
(define (get-focused-window)
(let ([f (get-active-frame)])
(and f
(send f get-focus-window))))
(define time-stamp current-milliseconds)
;;
;; Return list of window's ancestors from root down to window
;; (including window). Used for on-subwindow-char and on-subwindow-event.
;; get-parent returns #f for no parent.
;; If stop-at-top-level-window? is #t, then the ancestors up to the
;; first top-level-window are returned.
;;
(define ancestor-list
(lambda (window stop-at-top-level-window?)
(let loop ([w window] [l null])
(if (or (not w)
(and stop-at-top-level-window?
(is-a? w top-level-window<%>)))
l
(loop (send w get-parent) (cons w l))))))
;;
;; Returns #t if window is in active-frame, else #f.
;; get-parent returns () for no parent.
;;
(define in-active-frame?
(lambda (window)
(let ([frame (get-active-frame)])
(let loop ([window window])
(cond [(null? window) #f]
[(eq? window frame) #t]
[else (loop (send window get-parent))])))))
;;
;; Verify modifier list.
;; l, valid : lists of symbols.
;; returns first item in l *not* in valid, or else #f.
;;
(define verify-list
(lambda (l valid)
(cond [(null? l) #f]
[(member (car l) valid) (verify-list (cdr l) valid)]
[else (car l)])))
(define verify-item
(lambda (item valid)
(verify-list (list item) valid)))
;;;
;;; find-object obj-class b-desc
;;; returns an object belonging to obj-class, where b-desc
;;; is either an object, or a string
;;;
(define object-tag 'test:find-object)
;; find-object : class (union string (object -> boolean)) -> object
(define (find-object obj-class b-desc)
(lambda ()
(cond
[(or (string? b-desc)
(procedure? b-desc))
(let* ([active-frame (get-active-frame)]
[_ (unless active-frame
(error object-tag
"could not find object: ~a, no active frame"
b-desc))]
[child-matches?
(lambda (child)
(cond
[(string? b-desc)
(equal? (send child get-label) b-desc)]
[(procedure? b-desc)
(b-desc child)]))]
[found
(let loop ([panel active-frame])
(ormap (lambda (child)
(cond
[(and (is-a? child obj-class)
(child-matches? child))
child]
[(is-a? child area-container-window<%>)
(and (send child is-shown?)
(loop child))]
[(is-a? child area-container<%>)
(loop child)]
[else #f]))
(send panel get-children)))])
(or found
(error object-tag
"no object of class ~a named ~e in active frame"
obj-class
b-desc)))]
[(is-a? b-desc obj-class) b-desc]
[else (error
object-tag
"expected either a string or an object of class ~a as input, received: ~a"
obj-class b-desc)])))
;;; functions specific to various user input
;;; CONTROL functions, to be specialized for individual controls
(define control-action
(lambda (error-tag event-sym find-ctrl update-control)
(run-one
(lambda ()
(let ([event (make-object control-event% event-sym)]
[ctrl (find-ctrl)])
(cond
[(not (send ctrl is-shown?))
(error error-tag "control ~e is not shown (label ~e)" ctrl (send ctrl get-label))]
[(not (send ctrl is-enabled?))
(error error-tag "control ~e is not enabled (label ~e)" ctrl (send ctrl get-label))]
[(not (in-active-frame? ctrl))
(error error-tag "control ~e is not in active frame (label ~e)" ctrl (send ctrl get-label))]
[else
(update-control ctrl)
(send ctrl command event)
(void)]))))))
;;
;; BUTTON
;;
(define (button-push button)
(control-action
'test:button-push
'button
(find-object button% button)
void))
;;
;; CHECK-BOX
;;
(define (set-check-box! in-cb state)
(control-action
'test:set-check-box!
'check-box
(find-object check-box% in-cb)
(lambda (cb) (send cb set-value state))))
;;
;; RADIO-BOX
;;
(define (build-labels radio-box)
(string-append
(format "~s" (send radio-box get-item-label 0))
(let loop ([n (- (send radio-box get-number) 1)])
(cond
[(zero? n) ""]
[else (string-append " "
(format "~s"
(send radio-box get-item-label
(- (send radio-box get-number)
n)))
(loop (- n 1)))]))))
(define (set-radio-box! in-cb state)
(control-action
'test:set-radio-box!
'radio-box
(find-object radio-box% in-cb)
(lambda (rb)
(cond
[(string? state)
(let ([total (send rb get-number)])
(let loop ([n total])
(cond
[(zero? n) (error 'test:set-radio-box!
"did not find ~e as a label for ~e; labels: ~a"
state in-cb
(build-labels in-cb))]
[else (let ([i (- total n)])
(if (or (string=? state (send rb get-item-label i))
(string=? state (send rb get-item-plain-label i)))
(if (send rb is-enabled? i)
(send rb set-selection i)
(error 'test:set-radio-box!
"label ~e is disabled"
state))
(loop (- n 1))))])))]
[(number? state)
(unless (send rb is-enabled? state)
(error 'test:set-radio-box! "item ~a is not enabled~n" state))
(send rb set-selection state)]
[else (error 'test:set-radio-box!
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
state in-cb)]))))
;; set-radio-box-item! : string -> void
(define (set-radio-box-item! state)
(control-action
'test:set-check-box-state!
'radio-box
(find-object radio-box% (entry-matches state))
(lambda (rb)
(let ([total (send rb get-number)])
(let loop ([n total])
(cond
[(zero? n) (error 'test:set-radio-box-item! "internal error")]
[else (let ([i (- total n)])
(if (or (string=? state (send rb get-item-label i))
(string=? state (send rb get-item-plain-label i)))
(if (send rb is-enabled? i)
(send rb set-selection i)
(error 'test:set-radio-box!
"label ~e is disabled"
state))
(loop (- n 1))))]))))))
;; entry-matches : string -> radio-box -> boolean
(define (entry-matches name)
(lambda (rb)
(let loop ([n (send rb get-number)])
(and (not (zero? n))
(or (equal? name (send rb get-item-label (- n 1)))
(equal? name (send rb get-item-plain-label (- n 1)))
(loop (- n 1)))))))
;;; CHOICE
; set-choice! : ((instance in-choice%) (union string number) -> void)
(define (set-choice! in-choice str)
(control-action
'test:set-choice!
'choice
(find-object choice% in-choice)
(lambda (choice)
(cond
[(number? str) (send choice set-selection str)]
[(string? str) (send choice set-string-selection str)]
[else (error 'test:set-choice!
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
str in-choice)]))))
;;
;; KEYSTROKES
;;
;; Give ancestors (from root down) option of handling key event
;; with on-subwindow-char. If none want it, then send to focused window
;; with (send <window> on-char <wx:key-event>).
;;
;; key: char or integer.
;; optional modifiers: 'alt, 'control, 'meta, 'shift,
;; 'noalt, 'nocontrol, 'nometa, 'noshift.
;;
;; Window must be shown, in active frame, and either the window has
;; on-char, or else some ancestor must grab key with on-subwindow-char.
;;
(define key-tag 'test:keystroke)
(define legal-keystroke-modifiers
(list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))
(define valid-key-symbols
(list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print
'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2
'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9
'multiply 'add 'separator 'subtract 'decimal 'divide 'f1 'f2 'f3
'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12 'f13 'f14 'f15 'f16 'f17
'f18 'f19 'f20 'f21 'f22 'f23 'f24 'numlock 'scroll))
(define keystroke
(case-lambda
[(key) (keystroke key null)]
[(key modifier-list)
(cond
[(not (or (char? key) (memq key valid-key-symbols)))
(error key-tag "expects char or valid key symbol, given: ~e" key)]
[(not (list? modifier-list))
(error key-tag "expected a list as second argument, got: ~e" modifier-list)]
[(verify-list modifier-list legal-keystroke-modifiers)
=> (lambda (mod) (error key-tag "unknown key modifier: ~e" mod))]
[else
(run-one
(lambda ()
(let ([window (get-focused-window)])
(cond
[(not window)
(error key-tag "no focused window")]
[(not (send window is-shown?))
(error key-tag "focused window is not shown")]
[(not (send window is-enabled?))
(error key-tag "focused window is not enabled")]
[(not (in-active-frame? window))
(error key-tag "focused window is not in active frame")]
[else
(let ([event (make-key-event key window modifier-list)])
(send-key-event window event)
(void))]))))])]))
;; delay test for on-char until all ancestors decline on-subwindow-char.
(define (send-key-event window event)
(let loop ([l (ancestor-list window #t)])
(cond [(null? l)
(cond
[(method-in-interface? 'on-char (object-interface window))
(send window on-char event)]
[(is-a? window text-field%)
(send (send window get-editor) on-char event)]
[else
(error
key-tag
"focused window is not a text-field% and does not have on-char")])]
[(send (car l) on-subwindow-char window event) #f]
[else (loop (cdr l))])))
;; Make full key-event% object.
;; Shift is determined implicitly from key-code.
;; Alt, Meta, Control come from modifier-list.
;; get-alt-down, etc are #f unless explicitly set to #t.
;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED.
(define make-key-event
(lambda (key window modifier-list)
(let ([event (make-object key-event%)])
(send event set-key-code key)
(send event set-time-stamp (time-stamp))
(set-key-modifiers event key modifier-list)
event)))
(define set-key-modifiers
(lambda (event key modifier-list)
(when (shifted? key) (send event set-shift-down #t))
(let loop ([l modifier-list])
(unless (null? l)
(let ([mod (car l)])
(cond
[(eq? mod 'alt) (send event set-alt-down #t)]
[(eq? mod 'control) (send event set-control-down #t)]
[(eq? mod 'meta) (send event set-meta-down #t)]
[(eq? mod 'shift) (send event set-shift-down #t)]
[(eq? mod 'noalt) (send event set-alt-down #f)]
[(eq? mod 'nocontrol) (send event set-control-down #f)]
[(eq? mod 'nometa) (send event set-meta-down #f)]
[(eq? mod 'noshift) (send event set-shift-down #f)]
[else (error key-tag "unknown key modifier: ~e" mod)])
(loop (cdr l)))))))
(define shifted?
(let* ([shifted-keys '(#\? #\: #\~ #\\ #\|
#\< #\> #\{ #\} #\[ #\] #\( #\)
#\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)])
(lambda (key)
(memq shifted-keys shifted-keys))))
;;
;; MENU ITEMS
;;
;; Select menu item with:
;; (send <frame> command <menu-item-id>)
;; menu, item: strings
;;
;; DOESN'T HANDLE MENU CHECKBOXES YET.
;;
(define menu-tag 'test:menu-select)
(define menu-select
(lambda (menu-name . item-names)
(cond
[(not (string? menu-name))
(error menu-tag "expects string, given: ~e" menu-name)]
[(not (andmap string? item-names))
(error menu-tag "expects strings, given: ~e" item-names)]
[else
(run-one
(lambda ()
(let* ([frame (get-active-frame)]
[item (get-menu-item frame (cons menu-name item-names))]
[evt (make-object control-event% 'menu)])
(send evt set-time-stamp (current-milliseconds))
(send item command evt))))])))
(define get-menu-item
(lambda (frame item-names)
(cond
[(not frame)
(error menu-tag "no active frame")]
[(not (method-in-interface? 'get-menu-bar (object-interface frame)))
(error menu-tag "active frame does not have menu bar")]
[else
(let ([menu-bar (send frame get-menu-bar)])
(unless menu-bar
(error menu-tag "active frame does not have menu bar"))
(let* ([items (send menu-bar get-items)])
(let loop ([items items]
[this-name (car item-names)]
[wanted-names (cdr item-names)])
(cond
[(null? items)
(error 'menu-select "didn't find a menu: ~e, entire list: ~e" this-name item-names)]
[else (let ([i (car items)])
(cond
[(not (is-a? i labelled-menu-item<%>))
(loop (cdr items)
this-name
wanted-names)]
[(string=? this-name (send i get-plain-label))
(cond
[(and (null? wanted-names)
(not (is-a? i menu-item-container<%>)))
i]
[(and (not (null? wanted-names))
(is-a? i menu-item-container<%>))
(loop (send i get-items)
(car wanted-names)
(cdr wanted-names))]
[else
(error menu-tag "no menu matching ~e" item-names)])]
[else
(loop (cdr items)
this-name
wanted-names)]))]))))])))
;;
;; SIMPLE MOUSE EVENTS
;;
;; Simple left-click mouse in current canvas.
;; Sends 3 mouse-events to canvas: motion, down, up.
;;
;; Give ancestors (from root down) option of handling mouse event
;; with pre-on-event. If none want it, then send to focused window
;; with on-event.
;;
;; NEED TO EXPAND: DRAGGING, DOUBLE-CLICK, MOVING TO OTHER CANVASES,
;; MODIFIER KEYS (SHIFT, META, CONTROL, ALT).
;;
(define mouse-tag 'test:mouse-action)
(define legal-mouse-buttons (list 'left 'middle 'right))
(define legal-mouse-modifiers
(list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))
(define mouse-click
(case-lambda
[(button x y) (mouse-click button x y null)]
[(button x y modifier-list)
(cond
[(verify-item button legal-mouse-buttons)
=> (lambda (button)
(error mouse-tag "unknown mouse button: ~e" button))]
[(not (real? x))
(error mouse-tag "expected real, given: ~e" x)]
[(not (real? y))
(error mouse-tag "expected real, given: ~e" y)]
[(verify-list modifier-list legal-mouse-modifiers)
=> (lambda (mod)
(error mouse-tag "unknown mouse modifier: ~e" mod))]
[else
(run-one
(lambda ()
(let ([window (get-focused-window)])
(cond
[(not window)
(error mouse-tag "no focused window")]
[(not (send window is-shown?))
(error mouse-tag "focused window is not shown")]
[(not (send window is-enabled?))
(error mouse-tag "focused window is not enabled")]
[(not (in-active-frame? window))
(error mouse-tag "focused window is not in active frame")]
[else
(let ([motion (make-mouse-event 'motion x y modifier-list)]
[down (make-mouse-event (list button 'down) x y modifier-list)]
[up (make-mouse-event (list button 'up) x y modifier-list)])
(send-mouse-event window motion)
(send-mouse-event window down)
(send-mouse-event window up)
(void))]))))])]))
;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE.
(define send-mouse-event
(lambda (window event)
(let loop ([l (ancestor-list window #t)])
(cond
[(null? l)
(if (method-in-interface? 'on-event (object-interface window))
(send window on-event event)
(error mouse-tag "focused window does not have on-event"))]
[(send (car l) on-subwindow-event window event) #f]
[else (loop (cdr l))]))))
;;
;; Make mouse event.
;;
(define make-mouse-event
(lambda (type x y modifier-list)
(let ([event (make-object mouse-event% (mouse-type-const type))])
(when (and (pair? type) (not (eq? (cadr type) 'up)))
(set-mouse-modifiers event (list (car type))))
(set-mouse-modifiers event modifier-list)
(send event set-x x)
(send event set-y y)
(send event set-time-stamp (time-stamp))
event)))
(define set-mouse-modifiers
(lambda (event modifier-list)
(unless (null? modifier-list)
(let ([mod (car modifier-list)])
(cond
[(eq? mod 'alt) (send event set-alt-down #t)]
[(eq? mod 'control) (send event set-control-down #t)]
[(eq? mod 'meta) (send event set-meta-down #t)]
[(eq? mod 'shift) (send event set-shift-down #t)]
[(eq? mod 'left) (send event set-left-down #t)]
[(eq? mod 'middle) (send event set-middle-down #t)]
[(eq? mod 'right) (send event set-right-down #t)]
[(eq? mod 'noalt) (send event set-alt-down #f)]
[(eq? mod 'nocontrol) (send event set-control-down #f)]
[(eq? mod 'nometa) (send event set-meta-down #f)]
[(eq? mod 'noshift) (send event set-shift-down #f)]
[else (error mouse-tag "unknown mouse modifier: ~e" mod)]))
(set-mouse-modifiers event (cdr modifier-list)))))
(define mouse-type-const
(lambda (type)
(cond
[(symbol? type)
(cond
[(eq? type 'motion) 'motion]
[(eq? type 'enter) 'enter]
[(eq? type 'leave) 'leave]
[else (bad-mouse-type type)])]
[(and (pair? type) (pair? (cdr type)))
(let ([button (car type)] [action (cadr type)])
(cond
[(eq? button 'left)
(cond
[(eq? action 'down) 'left-down]
[(eq? action 'up) 'left-up]
[(eq? action 'dclick) 'left-dclick]
[else (bad-mouse-type type)])]
[(eq? button 'middle)
(cond
[(eq? action 'down) 'middle-down]
[(eq? action 'up) 'middle-up]
[(eq? action 'dclick) 'middle-dclick]
[else (bad-mouse-type type)])]
[(eq? button 'right)
(cond
[(eq? action 'down) 'right-down]
[(eq? action 'up) 'right-up]
[(eq? action 'dclick) 'right-dclick]
[else (bad-mouse-type type)])]
[else (bad-mouse-type type)]))]
[else (bad-mouse-type type)])))
(define bad-mouse-type
(lambda (type)
(error mouse-tag "unknown mouse event type: ~e" type)))
;;
;; Move mouse to new window.
;; Implement with three events:
;; leave old window, show top-level frame, enter new window, focus.
;;
;; NEED TO CLEAN UP ACTIONS FOR MOVING TO NEW FRAME.
;;
(define new-window
(let ([tag 'test:new-window])
(lambda (new-window)
(cond
[(not (is-a? new-window window<%>))
(error tag "new-window is not a window<%>")]
[else
(run-one
(lambda ()
(let
([old-window (get-focused-window)]
[leave (make-object mouse-event% 'leave)]
[enter (make-object mouse-event% 'enter)]
[root (car (ancestor-list new-window #t))])
(send leave set-x 0) (send leave set-y 0)
(send enter set-x 0) (send enter set-y 0)
;; SOME KLUDGES HERE TO WORK AROUND TEXT% PROBLEMS.
(when (and old-window (method-in-interface? 'on-event (object-interface old-window)))
(send-mouse-event old-window leave))
(send root show #t)
(when (method-in-interface? 'on-event (object-interface new-window))
(send-mouse-event new-window enter))
(send new-window focus)
(void))))]))))
(define (close-top-level-window tlw)
(when (send tlw can-close?)
(send tlw on-close)
(send tlw show #f)))
;; manual renaming
(define test:run-interval run-interval)
(define test:number-pending-actions number-pending-actions)
(define test:reraise-error reraise-error)
(define test:run-one run-one)
(define test:current-get-eventspaces current-get-eventspaces)
(define test:close-top-level-window close-top-level-window)
(define test:button-push button-push)
(define test:set-radio-box! set-radio-box!)
(define test:set-radio-box-item! set-radio-box-item!)
(define test:set-check-box! set-check-box!)
(define test:set-choice! set-choice!)
(define test:keystroke keystroke)
(define test:menu-select menu-select)
(define test:mouse-click mouse-click)
(define test:new-window new-window))