(module calm-evt mzscheme
  (require (lib ""))
  ;; calm-evt: acts as an event that fires off after a delay, if the event
  ;; doesn't do anything else by the time the delay times out.
  (define-values (struct:calm-evt make-calm-evt calm-evt? calm-evt-ref calm-evt-set!)
    (make-struct-type 'calm-evt #f 4 0 #f
                       (cons prop:evt
                             (lambda (a-calm-evt)
                               (thread-resume (calm-evt-helper-thread a-calm-evt)
                               (calm-evt-out-ch a-calm-evt))))
  (define calm-evt-wrapped-evt (make-struct-field-accessor calm-evt-ref 0))
  (define calm-evt-delay-in-milliseconds (make-struct-field-accessor calm-evt-ref 1))
  (define calm-evt-out-ch (make-struct-field-accessor calm-evt-ref 2))
  (define calm-evt-helper-thread (make-struct-field-accessor calm-evt-ref 3))
  ;; The default delay is a second.
  (define default-delay 1000)
  ;; -make-calm-evt: evt -> calm-evt
  ;; -make-calm-evt: evt natural-number -> calm-evt
  ;; Creates a calm-evt.
  (define -make-calm-evt
       (-make-calm-evt wrapped-evt default-delay)]
      [(wrapped-evt a-delay)
       (letrec ([a-calm-evt
                 (make-calm-evt wrapped-evt
                                 (lambda ()
                                   (helper-loop a-calm-evt))))])
  ;; helper-loop: calm-evt -> void
  ;; The helper loop waits for events to come off the wrapped event.
  ;; Once it does so, it squirrels away the value, and makes it ready for
  ;; delivery once timeout fires.
  ;; The finite state machine looks like:

                                                           -----------+ pick up value
               pick up value                               V          |
   --> start --------------> waiting-for-timeout-or-another-value ----+
          ^                                 |                  ^
          |                         timeout |                  |
          |                                 V                  |
          +---------------- allowing-value-to-be-delivered ----+ pick up value
            deliver value                   
  (define (helper-loop a-calm-evt)
    (let loop ([wait-for-timeout? #f]
               [value-box #f])
      (define (start?)
        (and (not wait-for-timeout?)
             (not value-box)))
      (define (goto-start)
        (loop #f #f))
      (define (waiting-for-timeout-or-another-value?)
        (and wait-for-timeout?
      (define (goto-waiting-for-timeout-or-another-value v)
        (loop #t (box v)))
      (define (allowing-value-to-be-delivered?)
        (and (not wait-for-timeout?)
      (define (goto-allowing-value-to-be-delivered)
        (loop #f value-box))
      (let* ([handle:pick-up-value
              (handle-evt (calm-evt-wrapped-evt a-calm-evt)
                          (lambda (v)
                            (goto-waiting-for-timeout-or-another-value v)))]
              (handle-evt (alarm-evt (+ (current-inexact-milliseconds)
                                        (calm-evt-delay-in-milliseconds a-calm-evt)))
                          (lambda (_)

              (lambda ()
                (handle-evt (channel-put-evt (calm-evt-out-ch a-calm-evt) (unbox value-box))
                            (lambda (_)
        (cond [(start?)
               (sync handle:pick-up-value)]
               (sync handle:pick-up-value
               (sync handle:pick-up-value
   [rename -make-calm-evt
           (case-> (evt? . -> . calm-evt?)
                   (evt? natural-number/c . -> . calm-evt?))]
   [calm-evt? (any/c . -> . boolean?)]))