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

original commit: cf548f197e19a3906ab6595726d73b5754d048cb

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?

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

collects/mred/private/mred.rkt

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

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
+                                                     (if peek?
-                                                      always-evt
+                                                         always-evt
-                                                      (lambda (_)
+                                                         (wrap-evt
-                                                        (start-atomic)
+                                                          always-evt
-                                                        (set! count (sub1 count))
+                                                          (lambda (_)
-                                                        (check-done)
+                                                            (start-atomic)
-                                                        (let ([result (mcar (mcar q))])
+                                                            (set! count (sub1 count))
-                                                          (set-mcar! q (mcdr (mcar q)))
+                                                            (check-done)
-                                                          (unless (mcar q)
+                                                            (let ([result (mcar (mcar q))])
-                                                            (set-mcdr! q #f))
+                                                              (set-mcar! q (mcdr (mcar q)))
-                                                          (end-atomic)
+                                                              (unless (mcar q)
-                                                          result)))))]
+                                                                (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
+                                    (begin0 
-                                           (lambda (timer)
+                                     (make-event-choice #f)
-                                             (let ([rb (unbox timer)])
+                                     (end-atomic))]
-                                               (and (not (null? rb))
+                                   [(only-refresh? peek?)
-                                                    (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
                                     (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))
 

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