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

attempted to rewrite docs into scribble -- that didnt work, but this is the leftover cleanup

Browse Source 
svn: r9463
This commit is contained in:
Robby Findler 2008-04-24 20:33:25 +00:00
parent e3a13be4a0
commit 06584c3941
1 changed files with 991 additions and 1017 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

412
collects/framework/test.ss
View File

@ -1,16 +1,15 @@
#reader scribble/reader
#lang scheme/gui
(module test mzscheme
(require mred
mzlib/class
mzlib/etc
mzlib/contract)
(require scribble/srcdoc)
(require/doc scheme/base scribble/manual)
(define-syntax (provide/contract/docs stx)
(define-syntax (provide/contract/docs stx)
(syntax-case stx ()
[(_ (name contract docs ...) ...)
(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)])
(and tlw
(let loop ([tlw tlw])
@ -18,18 +17,18 @@
(and (is-a? tlw area-container<%>)
(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
;; 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%).
;;
;;
;; 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
(define run-interval
(let ([tag 'test:run-interval]
[msec initial-run-interval])
(case-lambda
@ -38,34 +37,34 @@
(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.
;;
;;
;; How we get into the handler thread, and put fake actions
;; on the real event queue.
;;
(define install-timer
(define install-timer
(λ (msec thunk)
(let ([timer (instantiate timer% ()
[notify-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.
;;
;;
;; 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
(define-values (begin-action end-action end-action-with-error
get-exn-box is-exn? num-actions)
(let
([sem (make-semaphore 1)]
@ -117,29 +116,29 @@
(values begin-action end-action end-action-with-error
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)])
(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.
;;
;;
;; 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
(define run-one
(let ([yield-semaphore (make-semaphore 0)]
[thread-semaphore (make-semaphore 0)])
(thread
(rec loop
(λ ()
(let loop ()
(semaphore-wait thread-semaphore)
(sleep)
(semaphore-post yield-semaphore)
@ -169,62 +168,31 @@
(semaphore-wait sem)
(reraise-error))))))
;; new, queue-callback based run-one
'(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
(define current-get-eventspaces
(make-parameter (λ () (list (current-eventspace)))))
(define (get-active-frame)
(define (get-active-frame)
(ormap (λ (eventspace)
(parameterize ([current-eventspace eventspace])
(get-top-level-focus-window)))
((current-get-eventspaces))))
(define (get-focused-window)
(define (get-focused-window)
(let ([f (get-active-frame)])
(and f
(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
;; (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.
;;
;;
;; 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
(define ancestor-list
(λ (window stop-at-top-level-window?)
(let loop ([w window] [l null])
(if (or (not w)
@ -233,12 +201,12 @@
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.
;;
;;
;; Returns #t if window is in active-frame, else #f.
;; get-parent returns () for no parent.
;;
(define in-active-frame?
(define in-active-frame?
(λ (window)
(let ([frame (get-active-frame)])
(let loop ([window window])
@ -246,19 +214,19 @@
[(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.
;;
;;
;; Verify modifier list.
;; l, valid : lists of symbols.
;; returns first item in l *not* in valid, or else #f.
;;
(define verify-list
(define verify-list
(λ (l valid)
(cond [(null? l) #f]
[(member (car l) valid) (verify-list (cdr l) valid)]
[else (car l)])))
(define verify-item
(define verify-item
(λ (item valid)
(verify-list (list item) valid)))
@ -268,10 +236,10 @@
;;; 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
(define (find-object obj-class b-desc)
;; find-object : class (union string (object -> boolean)) -> object
(define (find-object obj-class b-desc)
(λ ()
(cond
[(or (string? b-desc)
@ -318,7 +286,7 @@
;;; CONTROL functions, to be specialized for individual controls
(define control-action
(define control-action
(λ (error-tag event-sym find-ctrl update-control)
(run-one
(λ ()
@ -336,11 +304,11 @@
(send ctrl command event)
(void)]))))))
;;
;; BUTTON
;;
;;
;; BUTTON
;;
(define (button-push button)
(define (button-push button)
(control-action
'test:button-push
'button
@ -351,7 +319,7 @@
;; CHECK-BOX
;;
(define (set-check-box! in-cb state)
(define (set-check-box! in-cb state)
(control-action
'test:set-check-box!
'check-box
@ -362,7 +330,7 @@
;; RADIO-BOX
;;
(define (build-labels 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)])
@ -375,7 +343,7 @@
n)))
(loop (- n 1)))]))))
(define (set-radio-box! in-cb state)
(define (set-radio-box! in-cb state)
(control-action
'test:set-radio-box!
'radio-box
@ -407,8 +375,8 @@
"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)
;; set-radio-box-item! : string -> void
(define (set-radio-box-item! state)
(control-action
'test:set-check-box-state!
'radio-box
@ -428,8 +396,8 @@
state))
(loop (- n 1))))]))))))
;; entry-matches : string -> radio-box -> boolean
(define (entry-matches name)
;; entry-matches : string -> radio-box -> boolean
(define (entry-matches name)
(λ (rb)
(let loop ([n (send rb get-number)])
(and (not (zero? n))
@ -440,7 +408,7 @@
;;; CHOICE
; set-choice! : ((instance in-choice%) (union string number) -> void)
(define (set-choice! in-choice str)
(define (set-choice! in-choice str)
(control-action
'test:set-choice!
'choice
@ -453,7 +421,7 @@
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
str in-choice)]))))
(define (set-list-box! in-lb str)
(define (set-list-box! in-lb str)
(control-action
'test:set-list-box!
'list-box
@ -466,27 +434,27 @@
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
str in-lb)]))))
;;
;; 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.
;;
;;
;; 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
(define key-tag 'test:keystroke)
(define legal-keystroke-modifiers
(list 'alt 'control 'meta 'shift
'noalt 'nocontrol 'nometa 'noshift))
(define valid-key-symbols
(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
@ -495,7 +463,7 @@
'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
(define keystroke
(case-lambda
[(key) (keystroke key null)]
[(key modifier-list)
@ -524,8 +492,8 @@
(send-key-event window event)
(void))]))))])]))
;; delay test for on-char until all ancestors decline on-subwindow-char.
(define (send-key-event window event)
;; 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
@ -540,13 +508,13 @@
[(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.
;; 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
(define make-key-event
(λ (key window modifier-list)
(let ([event (make-object key-event%)])
(send event set-key-code key)
@ -554,7 +522,7 @@
(set-key-modifiers event key modifier-list)
event)))
(define set-key-modifiers
(define set-key-modifiers
(λ (event key modifier-list)
(when (shifted? key) (send event set-shift-down #t))
(let loop ([l modifier-list])
@ -572,7 +540,7 @@
[else (error key-tag "unknown key modifier: ~e" mod)])
(loop (cdr l)))))))
(define shifted?
(define shifted?
(let* ([shifted-keys '(#\? #\: #\~ #\\ #\|
#\< #\> #\{ #\} #\[ #\] #\( #\)
#\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
@ -581,19 +549,19 @@
(λ (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.
;;
;;
;; 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-tag 'test:menu-select)
(define menu-select
(define menu-select
(λ (menu-name . item-names)
(cond
[(not (string? menu-name))
@ -609,7 +577,7 @@
(send evt set-time-stamp (current-milliseconds))
(send item command evt))))])))
(define get-menu-item
(define get-menu-item
(λ (frame item-names)
(cond
[(not frame)
@ -652,26 +620,26 @@
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).
;;
;;
;; 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
(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
(define mouse-click
(case-lambda
[(button x y) (mouse-click button x y null)]
[(button x y modifier-list)
@ -709,9 +677,9 @@
(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)
(let loop ([l (ancestor-list window #t)])
(cond
@ -724,11 +692,11 @@
#f]
[else (loop (cdr l))]))))
;;
;; Make mouse event.
;;
;;
;; Make mouse event.
;;
(define make-mouse-event
(define make-mouse-event
(λ (type x y modifier-list)
(let ([event (make-object mouse-event% (mouse-type-const type))])
(when (and (pair? type) (not (eq? (cadr type) 'up)))
@ -739,7 +707,7 @@
(send event set-time-stamp (time-stamp))
event)))
(define set-mouse-modifiers
(define set-mouse-modifiers
(λ (event modifier-list)
(unless (null? modifier-list)
(let ([mod (car modifier-list)])
@ -758,7 +726,7 @@
[else (error mouse-tag "unknown mouse modifier: ~e" mod)]))
(set-mouse-modifiers event (cdr modifier-list)))))
(define mouse-type-const
(define mouse-type-const
(λ (type)
(cond
[(symbol? type)
@ -791,19 +759,19 @@
[else (bad-mouse-type type)]))]
[else (bad-mouse-type type)])))
(define bad-mouse-type
(define bad-mouse-type
(λ (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.
;;
;;
;; 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
(define new-window
(let ([tag 'test:new-window])
(λ (new-window)
(cond
@ -830,30 +798,37 @@
(send new-window focus)
(void))))]))))
(define (close-top-level-window tlw)
(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:set-list-box! set-list-box!)
(define test:keystroke keystroke)
(define test:menu-select menu-select)
(define test:mouse-click mouse-click)
(define test:new-window new-window)
;; 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:set-list-box! set-list-box!)
(define test:keystroke keystroke)
(define test:menu-select menu-select)
(define test:mouse-click mouse-click)
(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
(-> number?)
()
@ -989,8 +964,7 @@
"that string, otherwise it uses \\var{list-box} itself.")
(test:keystroke
(opt->
((or/c char? symbol?))
(->* ((or/c char? symbol?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
void?)
((key)
@ -1028,7 +1002,7 @@
"use ``New'', not ``New Ctrl+m n''.")
(test:mouse-click
(opt->
(->*
((symbols 'left 'middle 'right)
(and/c exact? integer?)
(and/c exact? integer?))
@ -1059,4 +1033,4 @@
"Moves the keyboard focus to a new window within the currently active"
"frame. Unfortunately, neither this function nor any other function in"
"the test engine can cause the focus to move from the top-most (active)"
"frame. ")))
"frame. "))