Support timeouts in on-gestalt

minimart/demand-matcher.rkt

@@ -6,6 +6,7 @@
 (require "core.rkt")
 (require "gestalt.rkt")
 (require (only-in "route.rkt" matcher-key-set))
+(require "drivers/timer.rkt")
 
 (provide (except-out (struct-out demand-matcher) demand-matcher)
 	 (rename-out [make-demand-matcher demand-matcher])
@@ -125,25 +126,30 @@
 ;; projection results. If check-and-maybe-spawn-fn returns #f,
 ;; continues to wait; otherwise, takes the action(s) returned, and
 ;; quits.
-(define (on-gestalt check-and-maybe-spawn-fn
+(define (on-gestalt #:timeout-msec [timeout-msec #f]
+		    #:on-timeout [timeout-handler (lambda () '())]
+		    check-and-maybe-spawn-fn
 		    base-gestalt
 		    . gestalt-projections)
+  (define timer-id (gensym 'on-gestalt))
   (define aggregate-gestalt
     (apply gestalt-union
 	   base-gestalt
 	   (map projection->gestalt gestalt-projections)))
-  (spawn (lambda (e s)
+  (list
-	   (match e
+   (when timeout-msec (send (set-timer timer-id timeout-msec 'relative)))
-	     [(routing-update g)
+   (spawn (lambda (e s)
-	      (define projection-results
+	    (match e
-		(map (lambda (p) (gestalt-project/keys g p)) gestalt-projections))
+	      [(routing-update g)
-	      (define maybe-spawn (apply check-and-maybe-spawn-fn
+	       (define projection-results
-					 aggregate-gestalt
+		 (map (lambda (p) (gestalt-project/keys g p)) gestalt-projections))
-					 projection-results))
+	       (define maybe-spawn (apply check-and-maybe-spawn-fn
-	      (and maybe-spawn
+					  aggregate-gestalt
-		   (transition s
+					  projection-results))
-			       (list maybe-spawn
+	       (transition s (when maybe-spawn (list maybe-spawn (quit))))]
-				     (quit))))]
+	      [(message (timer-expired _ _) _ _)
-	     [_ #f]))
+	       (transition s (list (timeout-handler) (quit)))]
-	 (void)
+	      [_ #f]))
-	 aggregate-gestalt))
+	  (void)
+	  (gestalt-union aggregate-gestalt
+			 (sub (timer-expired timer-id ?))))))