From 5d5ce6e33f76e8117ab74d256f4c844d8ec7c5c0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 3 Feb 2005 20:50:34 +0000
Subject: [PATCH] .

original commit: cc7179d7ab8e0274b5a5590355c2a0aee18fe00d
---
 collects/framework/private/text.ss | 29 ++++++++++++++++++++++-------
 1 file changed, 22 insertions(+), 7 deletions(-)

diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss
index 3109b54b..df99c816 100644
--- a/collects/framework/private/text.ss
+++ b/collects/framework/private/text.ss
@@ -902,7 +902,7 @@ WARNING: printf is rebound in the body of the unit to always
           get-box-input-editor-snip%
           get-box-input-text%))
       
-      (define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector))
+      (define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector))
       (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
       
       (define msec-timeout 500)
@@ -1690,7 +1690,7 @@ WARNING: printf is rebound in the body of the unit to always
              ;; otherwise return #f
              (define (service-waiter a-peeker)
                (match a-peeker
-                 [($ peeker bytes skip-count pe resp-chan nack-evt)
+                 [($ peeker bytes skip-count pe resp-chan nack-evt polling?)
                   (cond
                     [(and pe (not (eq? pe peeker-evt)))
                      (choice-evt (channel-put-evt resp-chan #f)
@@ -1712,6 +1712,8 @@ WARNING: printf is rebound in the body of the unit to always
                               (if (is-a? nth readable-snip<%>)
                                   (send nth read-special src line col pos)
                                   nth)))])))]
+                    [polling? 
+                     (wrap-evt always-evt (λ (_) 0))]
                     [else
                      #f])]))
              
@@ -1765,11 +1767,24 @@ WARNING: printf is rebound in the body of the unit to always
                           0))))])))
         
         (define (peek-proc bstr skip-count progress-evt)
-          (nack-guard-evt
-           (λ (nack)
-             (let ([chan (make-channel)])
-               (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack))
-               chan))))
+          (poll-guard-evt
+           (lambda (polling?)
+             (when polling?
+               (printf "polling\n"))
+             (if polling?
+                 (let ([answer 
+                        (sync
+                         (nack-guard-evt
+                          (λ (nack)
+                            (let ([chan (make-channel)])
+                              (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #t))
+                              chan))))])
+                   (wrap-evt always-evt (λ (_) answer)))
+                 (nack-guard-evt
+                  (λ (nack)
+                    (let ([chan (make-channel)])
+                      (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack #f))
+                      chan)))))))
         
         (define (progress-evt-proc)
           (sync