attempted to rewrite docs into scribble -- that didnt work, but this is the leftover cleanup
svn: r9463 original commit: 06584c39412be42a3e93c8aec7468de865c4dc04
This commit is contained in:
Robby Findler
parent
e92ac89026
commit
6028ccaa4f
|
|
@ -1,16 +1,15 @@
|
||||||
|
#reader scribble/reader
|
||||||
|
#lang scheme/gui
|
||||||
|
|
||||||
(module test mzscheme
|
(require scribble/srcdoc)
|
||||||
(require mred
|
(require/doc scheme/base scribble/manual)
|
||||||
mzlib/class
|
|
||||||
mzlib/etc
|
|
||||||
mzlib/contract)
|
|
||||||
|
|
||||||
(define-syntax (provide/contract/docs stx)
|
(define-syntax (provide/contract/docs stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ (name contract docs ...) ...)
|
[(_ (name contract docs ...) ...)
|
||||||
(syntax (provide/contract (name contract) ...))]))
|
(syntax (provide/contract (name contract) ...))]))
|
||||||
|
|
||||||
(define (test:top-level-focus-window-has? pred)
|
(define (test:top-level-focus-window-has? pred)
|
||||||
(let ([tlw (get-top-level-focus-window)])
|
(let ([tlw (get-top-level-focus-window)])
|
||||||
(and tlw
|
(and tlw
|
||||||
(let loop ([tlw tlw])
|
(let loop ([tlw tlw])
|
||||||
|
|
@ -18,18 +17,18 @@
|
||||||
(and (is-a? tlw area-container<%>)
|
(and (is-a? tlw area-container<%>)
|
||||||
(ormap loop (send tlw get-children))))))))
|
(ormap loop (send tlw get-children))))))))
|
||||||
|
|
||||||
(define initial-run-interval 0) ;; milliseconds
|
(define initial-run-interval 0) ;; milliseconds
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; The minimum time an action is allowed to run before returning from
|
;; The minimum time an action is allowed to run before returning from
|
||||||
;; mred:test:action. Controls the rate at which actions are started,
|
;; mred:test:action. Controls the rate at which actions are started,
|
||||||
;; and gives some slack time for real events to complete (eg, update).
|
;; and gives some slack time for real events to complete (eg, update).
|
||||||
;; Make-parameter doesn't do what we need across threads.
|
;; Make-parameter doesn't do what we need across threads.
|
||||||
;; Probably don't need semaphores here (set! is atomic).
|
;; Probably don't need semaphores here (set! is atomic).
|
||||||
;; Units are in milliseconds (as in mred:timer%).
|
;; Units are in milliseconds (as in mred:timer%).
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define run-interval
|
(define run-interval
|
||||||
(let ([tag 'test:run-interval]
|
(let ([tag 'test:run-interval]
|
||||||
[msec initial-run-interval])
|
[msec initial-run-interval])
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
@ -38,34 +37,34 @@
|
||||||
(set! msec x)
|
(set! msec x)
|
||||||
(error tag "expects exact, non-negative integer, given: ~e" x))])))
|
(error tag "expects exact, non-negative integer, given: ~e" x))])))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; How we get into the handler thread, and put fake actions
|
;; How we get into the handler thread, and put fake actions
|
||||||
;; on the real event queue.
|
;; on the real event queue.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define install-timer
|
(define install-timer
|
||||||
(λ (msec thunk)
|
(λ (msec thunk)
|
||||||
(let ([timer (instantiate timer% ()
|
(let ([timer (instantiate timer% ()
|
||||||
[notify-callback (λ () (thunk))])])
|
[notify-callback (λ () (thunk))])])
|
||||||
(send timer start msec #t))))
|
(send timer start msec #t))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Simple accounting of actions and errors.
|
;; Simple accounting of actions and errors.
|
||||||
;;
|
;;
|
||||||
;; Keep number of unfinished actions. An error in the buffer
|
;; Keep number of unfinished actions. An error in the buffer
|
||||||
;; (caught but not-yet-reraised) counts as an unfinished action.
|
;; (caught but not-yet-reraised) counts as an unfinished action.
|
||||||
;; (but kept in the-error, not count).
|
;; (but kept in the-error, not count).
|
||||||
;;
|
;;
|
||||||
;; Keep buffer of one error, and reraise at first opportunity.
|
;; Keep buffer of one error, and reraise at first opportunity.
|
||||||
;; Keep just first error, any others are thrown on the floor.
|
;; Keep just first error, any others are thrown on the floor.
|
||||||
;; Reraising the error flushes the buffer.
|
;; Reraising the error flushes the buffer.
|
||||||
;; Store exn in box, so can correctly catch (raise #f).
|
;; Store exn in box, so can correctly catch (raise #f).
|
||||||
;;
|
;;
|
||||||
;; These values are set in handler thread and read in main thread,
|
;; These values are set in handler thread and read in main thread,
|
||||||
;; so certainly need semaphores here.
|
;; so certainly need semaphores here.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define-values (begin-action end-action end-action-with-error
|
(define-values (begin-action end-action end-action-with-error
|
||||||
get-exn-box is-exn? num-actions)
|
get-exn-box is-exn? num-actions)
|
||||||
(let
|
(let
|
||||||
([sem (make-semaphore 1)]
|
([sem (make-semaphore 1)]
|
||||||
|
|
@ -117,29 +116,29 @@
|
||||||
(values begin-action end-action end-action-with-error
|
(values begin-action end-action end-action-with-error
|
||||||
get-exn-box is-exn? num-actions))))
|
get-exn-box is-exn? num-actions))))
|
||||||
|
|
||||||
;; Functions to export, always in main thread.
|
;; Functions to export, always in main thread.
|
||||||
|
|
||||||
(define number-pending-actions num-actions)
|
(define number-pending-actions num-actions)
|
||||||
|
|
||||||
(define reraise-error
|
(define reraise-error
|
||||||
(λ ()
|
(λ ()
|
||||||
(let ([exn-box (get-exn-box)])
|
(let ([exn-box (get-exn-box)])
|
||||||
(if exn-box (raise (unbox exn-box)) (void)))))
|
(if exn-box (raise (unbox exn-box)) (void)))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Start running thunk in handler thread.
|
;; Start running thunk in handler thread.
|
||||||
;; Don't return until run-interval expires, and thunk finishes,
|
;; Don't return until run-interval expires, and thunk finishes,
|
||||||
;; raises error, or yields (ie, at event boundary).
|
;; raises error, or yields (ie, at event boundary).
|
||||||
;; Reraise error (if exists) even from previous action.
|
;; Reraise error (if exists) even from previous action.
|
||||||
;; Note: never more than one timer (of ours) on real event queue.
|
;; Note: never more than one timer (of ours) on real event queue.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define run-one
|
(define run-one
|
||||||
(let ([yield-semaphore (make-semaphore 0)]
|
(let ([yield-semaphore (make-semaphore 0)]
|
||||||
[thread-semaphore (make-semaphore 0)])
|
[thread-semaphore (make-semaphore 0)])
|
||||||
(thread
|
(thread
|
||||||
(rec loop
|
|
||||||
(λ ()
|
(λ ()
|
||||||
|
(let loop ()
|
||||||
(semaphore-wait thread-semaphore)
|
(semaphore-wait thread-semaphore)
|
||||||
(sleep)
|
(sleep)
|
||||||
(semaphore-post yield-semaphore)
|
(semaphore-post yield-semaphore)
|
||||||
|
|
@ -169,62 +168,31 @@
|
||||||
(semaphore-wait sem)
|
(semaphore-wait sem)
|
||||||
(reraise-error))))))
|
(reraise-error))))))
|
||||||
|
|
||||||
;; new, queue-callback based run-one
|
(define current-get-eventspaces
|
||||||
'(define run-one
|
|
||||||
(let ([yield-semaphore (make-semaphore 0)]
|
|
||||||
[thread-semaphore (make-semaphore 0)])
|
|
||||||
(thread
|
|
||||||
(rec loop
|
|
||||||
(λ ()
|
|
||||||
(semaphore-wait thread-semaphore)
|
|
||||||
(sleep)
|
|
||||||
(semaphore-post yield-semaphore)
|
|
||||||
(loop))))
|
|
||||||
(λ (thunk)
|
|
||||||
(let ([done (make-semaphore 0)])
|
|
||||||
(queue-callback
|
|
||||||
(λ ()
|
|
||||||
|
|
||||||
;; guarantee (probably) that some events are handled
|
|
||||||
(semaphore-post thread-semaphore)
|
|
||||||
(yield yield-semaphore)
|
|
||||||
|
|
||||||
(queue-callback (λ () (semaphore-post done)))
|
|
||||||
(unless (is-exn?)
|
|
||||||
(begin-action)
|
|
||||||
(parameterize ([current-exception-handler
|
|
||||||
(λ (exn)
|
|
||||||
(end-action-with-error exn)
|
|
||||||
((error-escape-handler)))])
|
|
||||||
(thunk))
|
|
||||||
(end-action))))
|
|
||||||
(semaphore-wait done)))))
|
|
||||||
|
|
||||||
(define current-get-eventspaces
|
|
||||||
(make-parameter (λ () (list (current-eventspace)))))
|
(make-parameter (λ () (list (current-eventspace)))))
|
||||||
|
|
||||||
(define (get-active-frame)
|
(define (get-active-frame)
|
||||||
(ormap (λ (eventspace)
|
(ormap (λ (eventspace)
|
||||||
(parameterize ([current-eventspace eventspace])
|
(parameterize ([current-eventspace eventspace])
|
||||||
(get-top-level-focus-window)))
|
(get-top-level-focus-window)))
|
||||||
((current-get-eventspaces))))
|
((current-get-eventspaces))))
|
||||||
|
|
||||||
(define (get-focused-window)
|
(define (get-focused-window)
|
||||||
(let ([f (get-active-frame)])
|
(let ([f (get-active-frame)])
|
||||||
(and f
|
(and f
|
||||||
(send f get-focus-window))))
|
(send f get-focus-window))))
|
||||||
|
|
||||||
(define time-stamp current-milliseconds)
|
(define time-stamp current-milliseconds)
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Return list of window's ancestors from root down to window
|
;; Return list of window's ancestors from root down to window
|
||||||
;; (including window). Used for on-subwindow-char and on-subwindow-event.
|
;; (including window). Used for on-subwindow-char and on-subwindow-event.
|
||||||
;; get-parent returns #f for no parent.
|
;; get-parent returns #f for no parent.
|
||||||
;; If stop-at-top-level-window? is #t, then the ancestors up to the
|
;; If stop-at-top-level-window? is #t, then the ancestors up to the
|
||||||
;; first top-level-window are returned.
|
;; first top-level-window are returned.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define ancestor-list
|
(define ancestor-list
|
||||||
(λ (window stop-at-top-level-window?)
|
(λ (window stop-at-top-level-window?)
|
||||||
(let loop ([w window] [l null])
|
(let loop ([w window] [l null])
|
||||||
(if (or (not w)
|
(if (or (not w)
|
||||||
|
|
@ -233,12 +201,12 @@
|
||||||
l
|
l
|
||||||
(loop (send w get-parent) (cons w l))))))
|
(loop (send w get-parent) (cons w l))))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Returns #t if window is in active-frame, else #f.
|
;; Returns #t if window is in active-frame, else #f.
|
||||||
;; get-parent returns () for no parent.
|
;; get-parent returns () for no parent.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define in-active-frame?
|
(define in-active-frame?
|
||||||
(λ (window)
|
(λ (window)
|
||||||
(let ([frame (get-active-frame)])
|
(let ([frame (get-active-frame)])
|
||||||
(let loop ([window window])
|
(let loop ([window window])
|
||||||
|
|
@ -246,19 +214,19 @@
|
||||||
[(eq? window frame) #t]
|
[(eq? window frame) #t]
|
||||||
[else (loop (send window get-parent))])))))
|
[else (loop (send window get-parent))])))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Verify modifier list.
|
;; Verify modifier list.
|
||||||
;; l, valid : lists of symbols.
|
;; l, valid : lists of symbols.
|
||||||
;; returns first item in l *not* in valid, or else #f.
|
;; returns first item in l *not* in valid, or else #f.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define verify-list
|
(define verify-list
|
||||||
(λ (l valid)
|
(λ (l valid)
|
||||||
(cond [(null? l) #f]
|
(cond [(null? l) #f]
|
||||||
[(member (car l) valid) (verify-list (cdr l) valid)]
|
[(member (car l) valid) (verify-list (cdr l) valid)]
|
||||||
[else (car l)])))
|
[else (car l)])))
|
||||||
|
|
||||||
(define verify-item
|
(define verify-item
|
||||||
(λ (item valid)
|
(λ (item valid)
|
||||||
(verify-list (list item) valid)))
|
(verify-list (list item) valid)))
|
||||||
|
|
||||||
|
|
@ -268,10 +236,10 @@
|
||||||
;;; is either an object, or a string
|
;;; is either an object, or a string
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define object-tag 'test:find-object)
|
(define object-tag 'test:find-object)
|
||||||
|
|
||||||
;; find-object : class (union string (object -> boolean)) -> object
|
;; find-object : class (union string (object -> boolean)) -> object
|
||||||
(define (find-object obj-class b-desc)
|
(define (find-object obj-class b-desc)
|
||||||
(λ ()
|
(λ ()
|
||||||
(cond
|
(cond
|
||||||
[(or (string? b-desc)
|
[(or (string? b-desc)
|
||||||
|
|
@ -318,7 +286,7 @@
|
||||||
|
|
||||||
;;; CONTROL functions, to be specialized for individual controls
|
;;; CONTROL functions, to be specialized for individual controls
|
||||||
|
|
||||||
(define control-action
|
(define control-action
|
||||||
(λ (error-tag event-sym find-ctrl update-control)
|
(λ (error-tag event-sym find-ctrl update-control)
|
||||||
(run-one
|
(run-one
|
||||||
(λ ()
|
(λ ()
|
||||||
|
|
@ -336,11 +304,11 @@
|
||||||
(send ctrl command event)
|
(send ctrl command event)
|
||||||
(void)]))))))
|
(void)]))))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; BUTTON
|
;; BUTTON
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define (button-push button)
|
(define (button-push button)
|
||||||
(control-action
|
(control-action
|
||||||
'test:button-push
|
'test:button-push
|
||||||
'button
|
'button
|
||||||
|
|
@ -351,7 +319,7 @@
|
||||||
;; CHECK-BOX
|
;; CHECK-BOX
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define (set-check-box! in-cb state)
|
(define (set-check-box! in-cb state)
|
||||||
(control-action
|
(control-action
|
||||||
'test:set-check-box!
|
'test:set-check-box!
|
||||||
'check-box
|
'check-box
|
||||||
|
|
@ -362,7 +330,7 @@
|
||||||
;; RADIO-BOX
|
;; RADIO-BOX
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define (build-labels radio-box)
|
(define (build-labels radio-box)
|
||||||
(string-append
|
(string-append
|
||||||
(format "~s" (send radio-box get-item-label 0))
|
(format "~s" (send radio-box get-item-label 0))
|
||||||
(let loop ([n (- (send radio-box get-number) 1)])
|
(let loop ([n (- (send radio-box get-number) 1)])
|
||||||
|
|
@ -375,7 +343,7 @@
|
||||||
n)))
|
n)))
|
||||||
(loop (- n 1)))]))))
|
(loop (- n 1)))]))))
|
||||||
|
|
||||||
(define (set-radio-box! in-cb state)
|
(define (set-radio-box! in-cb state)
|
||||||
(control-action
|
(control-action
|
||||||
'test:set-radio-box!
|
'test:set-radio-box!
|
||||||
'radio-box
|
'radio-box
|
||||||
|
|
@ -407,8 +375,8 @@
|
||||||
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
||||||
state in-cb)]))))
|
state in-cb)]))))
|
||||||
|
|
||||||
;; set-radio-box-item! : string -> void
|
;; set-radio-box-item! : string -> void
|
||||||
(define (set-radio-box-item! state)
|
(define (set-radio-box-item! state)
|
||||||
(control-action
|
(control-action
|
||||||
'test:set-check-box-state!
|
'test:set-check-box-state!
|
||||||
'radio-box
|
'radio-box
|
||||||
|
|
@ -428,8 +396,8 @@
|
||||||
state))
|
state))
|
||||||
(loop (- n 1))))]))))))
|
(loop (- n 1))))]))))))
|
||||||
|
|
||||||
;; entry-matches : string -> radio-box -> boolean
|
;; entry-matches : string -> radio-box -> boolean
|
||||||
(define (entry-matches name)
|
(define (entry-matches name)
|
||||||
(λ (rb)
|
(λ (rb)
|
||||||
(let loop ([n (send rb get-number)])
|
(let loop ([n (send rb get-number)])
|
||||||
(and (not (zero? n))
|
(and (not (zero? n))
|
||||||
|
|
@ -440,7 +408,7 @@
|
||||||
;;; CHOICE
|
;;; CHOICE
|
||||||
|
|
||||||
; set-choice! : ((instance in-choice%) (union string number) -> void)
|
; set-choice! : ((instance in-choice%) (union string number) -> void)
|
||||||
(define (set-choice! in-choice str)
|
(define (set-choice! in-choice str)
|
||||||
(control-action
|
(control-action
|
||||||
'test:set-choice!
|
'test:set-choice!
|
||||||
'choice
|
'choice
|
||||||
|
|
@ -453,7 +421,7 @@
|
||||||
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
||||||
str in-choice)]))))
|
str in-choice)]))))
|
||||||
|
|
||||||
(define (set-list-box! in-lb str)
|
(define (set-list-box! in-lb str)
|
||||||
(control-action
|
(control-action
|
||||||
'test:set-list-box!
|
'test:set-list-box!
|
||||||
'list-box
|
'list-box
|
||||||
|
|
@ -466,27 +434,27 @@
|
||||||
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
||||||
str in-lb)]))))
|
str in-lb)]))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; KEYSTROKES
|
;; KEYSTROKES
|
||||||
;;
|
;;
|
||||||
;; Give ancestors (from root down) option of handling key event
|
;; Give ancestors (from root down) option of handling key event
|
||||||
;; with on-subwindow-char. If none want it, then send to focused window
|
;; with on-subwindow-char. If none want it, then send to focused window
|
||||||
;; with (send <window> on-char <wx:key-event>).
|
;; with (send <window> on-char <wx:key-event>).
|
||||||
;;
|
;;
|
||||||
;; key: char or integer.
|
;; key: char or integer.
|
||||||
;; optional modifiers: 'alt, 'control, 'meta, 'shift,
|
;; optional modifiers: 'alt, 'control, 'meta, 'shift,
|
||||||
;; 'noalt, 'nocontrol, 'nometa, 'noshift.
|
;; 'noalt, 'nocontrol, 'nometa, 'noshift.
|
||||||
;;
|
;;
|
||||||
;; Window must be shown, in active frame, and either the window has
|
;; 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.
|
;; on-char, or else some ancestor must grab key with on-subwindow-char.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define key-tag 'test:keystroke)
|
(define key-tag 'test:keystroke)
|
||||||
(define legal-keystroke-modifiers
|
(define legal-keystroke-modifiers
|
||||||
(list 'alt 'control 'meta 'shift
|
(list 'alt 'control 'meta 'shift
|
||||||
'noalt 'nocontrol 'nometa 'noshift))
|
'noalt 'nocontrol 'nometa 'noshift))
|
||||||
|
|
||||||
(define valid-key-symbols
|
(define valid-key-symbols
|
||||||
(list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
|
(list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
|
||||||
'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print
|
'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print
|
||||||
'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2
|
'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2
|
||||||
|
|
@ -495,7 +463,7 @@
|
||||||
'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12 'f13 'f14 'f15 'f16 'f17
|
'f4 'f5 'f6 'f7 'f8 'f9 'f10 'f11 'f12 'f13 'f14 'f15 'f16 'f17
|
||||||
'f18 'f19 'f20 'f21 'f22 'f23 'f24 'numlock 'scroll))
|
'f18 'f19 'f20 'f21 'f22 'f23 'f24 'numlock 'scroll))
|
||||||
|
|
||||||
(define keystroke
|
(define keystroke
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(key) (keystroke key null)]
|
[(key) (keystroke key null)]
|
||||||
[(key modifier-list)
|
[(key modifier-list)
|
||||||
|
|
@ -524,8 +492,8 @@
|
||||||
(send-key-event window event)
|
(send-key-event window event)
|
||||||
(void))]))))])]))
|
(void))]))))])]))
|
||||||
|
|
||||||
;; delay test for on-char until all ancestors decline on-subwindow-char.
|
;; delay test for on-char until all ancestors decline on-subwindow-char.
|
||||||
(define (send-key-event window event)
|
(define (send-key-event window event)
|
||||||
(let loop ([l (ancestor-list window #t)])
|
(let loop ([l (ancestor-list window #t)])
|
||||||
(cond [(null? l)
|
(cond [(null? l)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -540,13 +508,13 @@
|
||||||
[(send (car l) on-subwindow-char window event) #f]
|
[(send (car l) on-subwindow-char window event) #f]
|
||||||
[else (loop (cdr l))])))
|
[else (loop (cdr l))])))
|
||||||
|
|
||||||
;; Make full key-event% object.
|
;; Make full key-event% object.
|
||||||
;; Shift is determined implicitly from key-code.
|
;; Shift is determined implicitly from key-code.
|
||||||
;; Alt, Meta, Control come from modifier-list.
|
;; Alt, Meta, Control come from modifier-list.
|
||||||
;; get-alt-down, etc are #f unless explicitly set to #t.
|
;; get-alt-down, etc are #f unless explicitly set to #t.
|
||||||
;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED.
|
;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED.
|
||||||
|
|
||||||
(define make-key-event
|
(define make-key-event
|
||||||
(λ (key window modifier-list)
|
(λ (key window modifier-list)
|
||||||
(let ([event (make-object key-event%)])
|
(let ([event (make-object key-event%)])
|
||||||
(send event set-key-code key)
|
(send event set-key-code key)
|
||||||
|
|
@ -554,7 +522,7 @@
|
||||||
(set-key-modifiers event key modifier-list)
|
(set-key-modifiers event key modifier-list)
|
||||||
event)))
|
event)))
|
||||||
|
|
||||||
(define set-key-modifiers
|
(define set-key-modifiers
|
||||||
(λ (event key modifier-list)
|
(λ (event key modifier-list)
|
||||||
(when (shifted? key) (send event set-shift-down #t))
|
(when (shifted? key) (send event set-shift-down #t))
|
||||||
(let loop ([l modifier-list])
|
(let loop ([l modifier-list])
|
||||||
|
|
@ -572,7 +540,7 @@
|
||||||
[else (error key-tag "unknown key modifier: ~e" mod)])
|
[else (error key-tag "unknown key modifier: ~e" mod)])
|
||||||
(loop (cdr l)))))))
|
(loop (cdr l)))))))
|
||||||
|
|
||||||
(define shifted?
|
(define shifted?
|
||||||
(let* ([shifted-keys '(#\? #\: #\~ #\\ #\|
|
(let* ([shifted-keys '(#\? #\: #\~ #\\ #\|
|
||||||
#\< #\> #\{ #\} #\[ #\] #\( #\)
|
#\< #\> #\{ #\} #\[ #\] #\( #\)
|
||||||
#\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
|
#\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
|
||||||
|
|
@ -581,19 +549,19 @@
|
||||||
(λ (key)
|
(λ (key)
|
||||||
(memq shifted-keys shifted-keys))))
|
(memq shifted-keys shifted-keys))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; MENU ITEMS
|
;; MENU ITEMS
|
||||||
;;
|
;;
|
||||||
;; Select menu item with:
|
;; Select menu item with:
|
||||||
;; (send <frame> command <menu-item-id>)
|
;; (send <frame> command <menu-item-id>)
|
||||||
;; menu, item: strings
|
;; menu, item: strings
|
||||||
;;
|
;;
|
||||||
;; DOESN'T HANDLE MENU CHECKBOXES YET.
|
;; DOESN'T HANDLE MENU CHECKBOXES YET.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define menu-tag 'test:menu-select)
|
(define menu-tag 'test:menu-select)
|
||||||
|
|
||||||
(define menu-select
|
(define menu-select
|
||||||
(λ (menu-name . item-names)
|
(λ (menu-name . item-names)
|
||||||
(cond
|
(cond
|
||||||
[(not (string? menu-name))
|
[(not (string? menu-name))
|
||||||
|
|
@ -609,7 +577,7 @@
|
||||||
(send evt set-time-stamp (current-milliseconds))
|
(send evt set-time-stamp (current-milliseconds))
|
||||||
(send item command evt))))])))
|
(send item command evt))))])))
|
||||||
|
|
||||||
(define get-menu-item
|
(define get-menu-item
|
||||||
(λ (frame item-names)
|
(λ (frame item-names)
|
||||||
(cond
|
(cond
|
||||||
[(not frame)
|
[(not frame)
|
||||||
|
|
@ -652,26 +620,26 @@
|
||||||
wanted-names)]))]))))])))
|
wanted-names)]))]))))])))
|
||||||
|
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; SIMPLE MOUSE EVENTS
|
;; SIMPLE MOUSE EVENTS
|
||||||
;;
|
;;
|
||||||
;; Simple left-click mouse in current canvas.
|
;; Simple left-click mouse in current canvas.
|
||||||
;; Sends 3 mouse-events to canvas: motion, down, up.
|
;; Sends 3 mouse-events to canvas: motion, down, up.
|
||||||
;;
|
;;
|
||||||
;; Give ancestors (from root down) option of handling mouse event
|
;; Give ancestors (from root down) option of handling mouse event
|
||||||
;; with pre-on-event. If none want it, then send to focused window
|
;; with pre-on-event. If none want it, then send to focused window
|
||||||
;; with on-event.
|
;; with on-event.
|
||||||
;;
|
;;
|
||||||
;; NEED TO EXPAND: DRAGGING, DOUBLE-CLICK, MOVING TO OTHER CANVASES,
|
;; NEED TO EXPAND: DRAGGING, DOUBLE-CLICK, MOVING TO OTHER CANVASES,
|
||||||
;; MODIFIER KEYS (SHIFT, META, CONTROL, ALT).
|
;; MODIFIER KEYS (SHIFT, META, CONTROL, ALT).
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define mouse-tag 'test:mouse-action)
|
(define mouse-tag 'test:mouse-action)
|
||||||
(define legal-mouse-buttons (list 'left 'middle 'right))
|
(define legal-mouse-buttons (list 'left 'middle 'right))
|
||||||
(define legal-mouse-modifiers
|
(define legal-mouse-modifiers
|
||||||
(list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))
|
(list 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))
|
||||||
|
|
||||||
(define mouse-click
|
(define mouse-click
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(button x y) (mouse-click button x y null)]
|
[(button x y) (mouse-click button x y null)]
|
||||||
[(button x y modifier-list)
|
[(button x y modifier-list)
|
||||||
|
|
@ -709,9 +677,9 @@
|
||||||
(void))]))))])]))
|
(void))]))))])]))
|
||||||
|
|
||||||
|
|
||||||
;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE.
|
;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE.
|
||||||
|
|
||||||
(define send-mouse-event
|
(define send-mouse-event
|
||||||
(λ (window event)
|
(λ (window event)
|
||||||
(let loop ([l (ancestor-list window #t)])
|
(let loop ([l (ancestor-list window #t)])
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -724,11 +692,11 @@
|
||||||
#f]
|
#f]
|
||||||
[else (loop (cdr l))]))))
|
[else (loop (cdr l))]))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Make mouse event.
|
;; Make mouse event.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define make-mouse-event
|
(define make-mouse-event
|
||||||
(λ (type x y modifier-list)
|
(λ (type x y modifier-list)
|
||||||
(let ([event (make-object mouse-event% (mouse-type-const type))])
|
(let ([event (make-object mouse-event% (mouse-type-const type))])
|
||||||
(when (and (pair? type) (not (eq? (cadr type) 'up)))
|
(when (and (pair? type) (not (eq? (cadr type) 'up)))
|
||||||
|
|
@ -739,7 +707,7 @@
|
||||||
(send event set-time-stamp (time-stamp))
|
(send event set-time-stamp (time-stamp))
|
||||||
event)))
|
event)))
|
||||||
|
|
||||||
(define set-mouse-modifiers
|
(define set-mouse-modifiers
|
||||||
(λ (event modifier-list)
|
(λ (event modifier-list)
|
||||||
(unless (null? modifier-list)
|
(unless (null? modifier-list)
|
||||||
(let ([mod (car modifier-list)])
|
(let ([mod (car modifier-list)])
|
||||||
|
|
@ -758,7 +726,7 @@
|
||||||
[else (error mouse-tag "unknown mouse modifier: ~e" mod)]))
|
[else (error mouse-tag "unknown mouse modifier: ~e" mod)]))
|
||||||
(set-mouse-modifiers event (cdr modifier-list)))))
|
(set-mouse-modifiers event (cdr modifier-list)))))
|
||||||
|
|
||||||
(define mouse-type-const
|
(define mouse-type-const
|
||||||
(λ (type)
|
(λ (type)
|
||||||
(cond
|
(cond
|
||||||
[(symbol? type)
|
[(symbol? type)
|
||||||
|
|
@ -791,19 +759,19 @@
|
||||||
[else (bad-mouse-type type)]))]
|
[else (bad-mouse-type type)]))]
|
||||||
[else (bad-mouse-type type)])))
|
[else (bad-mouse-type type)])))
|
||||||
|
|
||||||
(define bad-mouse-type
|
(define bad-mouse-type
|
||||||
(λ (type)
|
(λ (type)
|
||||||
(error mouse-tag "unknown mouse event type: ~e" type)))
|
(error mouse-tag "unknown mouse event type: ~e" type)))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Move mouse to new window.
|
;; Move mouse to new window.
|
||||||
;; Implement with three events:
|
;; Implement with three events:
|
||||||
;; leave old window, show top-level frame, enter new window, focus.
|
;; leave old window, show top-level frame, enter new window, focus.
|
||||||
;;
|
;;
|
||||||
;; NEED TO CLEAN UP ACTIONS FOR MOVING TO NEW FRAME.
|
;; NEED TO CLEAN UP ACTIONS FOR MOVING TO NEW FRAME.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define new-window
|
(define new-window
|
||||||
(let ([tag 'test:new-window])
|
(let ([tag 'test:new-window])
|
||||||
(λ (new-window)
|
(λ (new-window)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -830,30 +798,37 @@
|
||||||
(send new-window focus)
|
(send new-window focus)
|
||||||
(void))))]))))
|
(void))))]))))
|
||||||
|
|
||||||
(define (close-top-level-window tlw)
|
(define (close-top-level-window tlw)
|
||||||
(when (send tlw can-close?)
|
(when (send tlw can-close?)
|
||||||
(send tlw on-close)
|
(send tlw on-close)
|
||||||
(send tlw show #f)))
|
(send tlw show #f)))
|
||||||
|
|
||||||
;; manual renaming
|
;; manual renaming
|
||||||
(define test:run-interval run-interval)
|
(define test:run-interval run-interval)
|
||||||
(define test:number-pending-actions number-pending-actions)
|
(define test:number-pending-actions number-pending-actions)
|
||||||
(define test:reraise-error reraise-error)
|
(define test:reraise-error reraise-error)
|
||||||
(define test:run-one run-one)
|
(define test:run-one run-one)
|
||||||
(define test:current-get-eventspaces current-get-eventspaces)
|
(define test:current-get-eventspaces current-get-eventspaces)
|
||||||
(define test:close-top-level-window close-top-level-window)
|
(define test:close-top-level-window close-top-level-window)
|
||||||
(define test:button-push button-push)
|
(define test:button-push button-push)
|
||||||
(define test:set-radio-box! set-radio-box!)
|
(define test:set-radio-box! set-radio-box!)
|
||||||
(define test:set-radio-box-item! set-radio-box-item!)
|
(define test:set-radio-box-item! set-radio-box-item!)
|
||||||
(define test:set-check-box! set-check-box!)
|
(define test:set-check-box! set-check-box!)
|
||||||
(define test:set-choice! set-choice!)
|
(define test:set-choice! set-choice!)
|
||||||
(define test:set-list-box! set-list-box!)
|
(define test:set-list-box! set-list-box!)
|
||||||
(define test:keystroke keystroke)
|
(define test:keystroke keystroke)
|
||||||
(define test:menu-select menu-select)
|
(define test:menu-select menu-select)
|
||||||
(define test:mouse-click mouse-click)
|
(define test:mouse-click mouse-click)
|
||||||
(define test:new-window new-window)
|
(define test:new-window new-window)
|
||||||
|
|
||||||
(provide/contract/docs
|
#;
|
||||||
|
(provide/doc
|
||||||
|
(proc-doc
|
||||||
|
test:number-pending-actions
|
||||||
|
(-> number?)
|
||||||
|
@{Returns the number of pending events (those that haven't completed yet)}))
|
||||||
|
|
||||||
|
(provide/contract/docs
|
||||||
(test:number-pending-actions
|
(test:number-pending-actions
|
||||||
(-> number?)
|
(-> number?)
|
||||||
()
|
()
|
||||||
|
|
@ -989,8 +964,7 @@
|
||||||
"that string, otherwise it uses \\var{list-box} itself.")
|
"that string, otherwise it uses \\var{list-box} itself.")
|
||||||
|
|
||||||
(test:keystroke
|
(test:keystroke
|
||||||
(opt->
|
(->* ((or/c char? symbol?))
|
||||||
((or/c char? symbol?))
|
|
||||||
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
|
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
|
||||||
void?)
|
void?)
|
||||||
((key)
|
((key)
|
||||||
|
|
@ -1028,7 +1002,7 @@
|
||||||
"use ``New'', not ``New Ctrl+m n''.")
|
"use ``New'', not ``New Ctrl+m n''.")
|
||||||
|
|
||||||
(test:mouse-click
|
(test:mouse-click
|
||||||
(opt->
|
(->*
|
||||||
((symbols 'left 'middle 'right)
|
((symbols 'left 'middle 'right)
|
||||||
(and/c exact? integer?)
|
(and/c exact? integer?)
|
||||||
(and/c exact? integer?))
|
(and/c exact? integer?))
|
||||||
|
|
@ -1059,4 +1033,4 @@
|
||||||
"Moves the keyboard focus to a new window within the currently active"
|
"Moves the keyboard focus to a new window within the currently active"
|
||||||
"frame. Unfortunately, neither this function nor any other function in"
|
"frame. Unfortunately, neither this function nor any other function in"
|
||||||
"the test engine can cause the focus to move from the top-most (active)"
|
"the test engine can cause the focus to move from the top-most (active)"
|
||||||
"frame. ")))
|
"frame. "))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user