diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 472db185..fc8dec47 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -62,6 +62,7 @@ editor<%> end-busy-cursor event% event-dispatch-handler +eventspace-event-evt eventspace-handler-thread eventspace-shutdown? eventspace? diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 909d9f2a..fa2475b0 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -28,6 +28,7 @@ eventspace-shutdown? main-eventspace? eventspace-handler-thread + eventspace-event-evt queue-callback middle-queue-key get-top-level-windows diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index ee2c4b95..72594f60 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -146,6 +146,7 @@ queue-callback yield eventspace-shutdown? + eventspace-event-evt get-panel-background the-editor-wordbreak-map diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 1ed6ed3f..d7b66d45 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -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)) diff --git a/collects/scribblings/gui/eventspace-funcs.scrbl b/collects/scribblings/gui/eventspace-funcs.scrbl index 511630d5..8d00eb0d 100644 --- a/collects/scribblings/gui/eventspace-funcs.scrbl +++ b/collects/scribblings/gui/eventspace-funcs.scrbl @@ -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