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

add eventspace-event-evt' to racket/gui/base'

Browse Source 
original commit: cf548f197e19a3906ab6595726d73b5754d048cb
This commit is contained in:
Matthew Flatt 2011-01-24 14:07:10 -07:00
parent 1becc8b95b
commit a22f20b771
5 changed files with 85 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/mred-sig.rkt
View File

@ -62,6 +62,7 @@ editor<%>
end-busy-cursor
event%
event-dispatch-handler
eventspace-event-evt
eventspace-handler-thread
eventspace-shutdown?
eventspace?

1
collects/mred/private/kernel.rkt
View File

@ -28,6 +28,7 @@
eventspace-shutdown?
main-eventspace?
eventspace-handler-thread
eventspace-event-evt
queue-callback
middle-queue-key
get-top-level-windows

1
collects/mred/private/mred.rkt
View File

@ -146,6 +146,7 @@
queue-callback
yield
eventspace-shutdown?
eventspace-event-evt
get-panel-background
the-editor-wordbreak-map

125
collects/mred/private/wx/common/queue.rkt
View File

@ -26,12 +26,14 @@
queue-refresh-event
yield
yield-refresh
eventspace-event-evt
(rename-out [make-new-eventspace make-eventspace])
event-dispatch-handler
eventspace-shutdown?
main-eventspace?
eventspace-handler-thread
eventspace-event-evt
eventspace-wait-cursor-count
eventspace-extra-table
eventspace-adjust-external-modal!
@ -235,27 +237,66 @@
(set-mcdr! (mcdr q) p)
(set-mcar! q p))
(set-mcdr! q p)))]
[first (lambda (q)
[first (lambda (q peek?)
(and (mcar q)
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(set! count (sub1 count))
(check-done)
(let ([result (mcar (mcar q))])
(set-mcar! q (mcdr (mcar q)))
(unless (mcar q)
(set-mcdr! q #f))
(end-atomic)
result)))))]
(if peek?
always-evt
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(set! count (sub1 count))
(check-done)
(let ([result (mcar (mcar q))])
(set-mcar! q (mcdr (mcar q)))
(unless (mcar q)
(set-mcdr! q #f))
(end-atomic)
result))))))]
[remove-timer
(lambda (v timer)
(set-box! timer (rbtree-remove
timed-compare
v
(unbox timer)))
(check-done))])
(check-done))]
[timer-first-ready
(lambda (timer peek?)
(let ([rb (unbox timer)])
(and (not (null? rb))
(let* ([v (rbtree-min (unbox timer))]
[evt (timed-alarm-evt v)])
(and (sync/timeout 0 evt)
;; It's ready
(if peek?
always-evt
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(remove-timer v timer)
(end-atomic)
(timed-val v)))))))))]
[timer-first-wait
(lambda (timer peek?)
(let ([rb (unbox timer)])
(and (not (null? rb))
(wrap-evt
(timed-alarm-evt (rbtree-min (unbox timer)))
(lambda (_) #f)))))]
[make-event-choice
(lambda (peek?)
(choice-evt
(wrap-evt (semaphore-peek-evt newly-posted-sema)
(lambda (_) #f))
(or (first hi peek?)
(timer-first-ready timer peek?)
(first refresh peek?)
(first med peek?)
(first lo peek?)
(timer-first-wait timer peek?)
;; nothing else ready...
never-evt)))])
(case-lambda
[(v)
;; Enqueue
@ -285,46 +326,18 @@
[()
;; Dequeue as evt
(start-atomic)
(let ([timer-first-ready
(lambda (timer)
(let ([rb (unbox timer)])
(and (not (null? rb))
(let* ([v (rbtree-min (unbox timer))]
[evt (timed-alarm-evt v)])
(and (sync/timeout 0 evt)
;; It's ready
(wrap-evt
always-evt
(lambda (_)
(start-atomic)
(remove-timer v timer)
(end-atomic)
(timed-val v))))))))]
[timer-first-wait
(lambda (timer)
(let ([rb (unbox timer)])
(and (not (null? rb))
(wrap-evt
(timed-alarm-evt (rbtree-min (unbox timer)))
(lambda (_) #f)))))])
(let ([e (choice-evt
(wrap-evt (semaphore-peek-evt newly-posted-sema)
(lambda (_) #f))
(or (first hi)
(timer-first-ready timer)
(first refresh)
(first med)
(first lo)
(timer-first-wait timer)
;; nothing else ready...
never-evt))])
(end-atomic)
e))]
[(_1 _2)
;; Dequeue only refresh event
(begin0
(make-event-choice #f)
(end-atomic))]
[(only-refresh? peek?)
(start-atomic)
(begin0
(or (first refresh) never-evt)
(cond
[only-refresh?
;; Dequeue only refresh event
(or (first refresh peek?) never-evt)]
[else
(make-event-choice #t)])
(end-atomic))]))))
frames
(semaphore-peek-evt done-sema)
@ -448,13 +461,19 @@
(let ([e (current-eventspace)])
(and (eq? (current-thread) (eventspace-handler-thread e))
(let loop ([result #f])
(let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f))])
(let ([v (sync/timeout 0 ((eventspace-queue-proc e) #t #f))])
(if v
(begin
(handle-event v e)
(loop #t))
result)))))))
(define (eventspace-event-evt [e (current-eventspace)])
(unless (eventspace? e)
(raise-type-error 'eventspace-event-evt "eventspace" e))
(wrap-evt ((eventspace-queue-proc e) #f #t)
(lambda (_) e)))
(define (main-eventspace? e)
(eq? e main-eventspace))

10
collects/scribblings/gui/eventspace-funcs.scrbl
View File

@ -50,6 +50,16 @@ An event dispatch handler must ultimately call the primitive event
directly by the eventspace handler thread.
}
@defproc[(eventspace-event-evt [e eventspace? (current-eventspace)]) evt?]{
Produces a synchronizable event (see @racket[sync]) that is ready when
a GUI event (mouse or keyboard action, update event, timer, queued
callback, etc.) is ready for dispatch in @racket[e]. That is, the
result event is ready when @racket[(yield)] for the eventspace
@racket[e] would dispatch a GUI event.}
@defproc[(check-for-break)
boolean?]{
Inspects the event queue of the current eventspace, searching for a