From aa629c8bbe4ad8109fcfb4b88bd9637a34d66643 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Wed, 11 Jun 2014 16:02:46 -0400
Subject: [PATCH] send-ground-message

---
 minimart/ground.rkt | 63 ++++++++++++++++++++++++++-------------------
 1 file changed, 37 insertions(+), 26 deletions(-)

diff --git a/minimart/ground.rkt b/minimart/ground.rkt
index cae2055..54bc532 100644
--- a/minimart/ground.rkt
+++ b/minimart/ground.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
 
+(require racket/async-channel)
 (require racket/set)
 (require racket/match)
 (require racket/list)
@@ -7,10 +8,18 @@
 (require "gestalt.rkt")
 
 (provide (struct-out event)
+	 send-ground-message
 	 run-ground)
 
 (struct event (descriptor values) #:prefab)
 
+(define current-ground-event-async-channel (make-parameter #f))
+
+(define (send-ground-message body)
+  (match (current-ground-event-async-channel)
+    [(? async-channel? ch) (async-channel-put ch (send body))]
+    [_ (error 'send-ground-message "Called outside dynamic scope of run-ground")]))
+
 (define (event-handler descriptor)
   (handle-evt descriptor (lambda vs (send (event descriptor vs)))))
 
@@ -31,29 +40,31 @@
   (handle-evt (system-idle-evt) (lambda _ #f)))
 
 (define (run-ground . boot-actions)
-  (let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '()))
-    (define event-list (if inert?
-			   active-events
-			   (cons idle-handler active-events)))
-    (if (null? event-list)
-	(begin (log-info "run-ground: Terminating because inert")
-	       (void))
-	(let ((e (apply sync event-list)))
-	  (match (deliver-event e -2 p)
-	    [#f ;; inert
-	     (await-interrupt #t p active-events)]
-	    [(transition new-state actions)
-	     (let process-actions ((actions (flatten actions)) (active-events active-events))
-	       (match actions
-		 ['()
-		  (await-interrupt #f (struct-copy process p [state new-state]) active-events)]
-		 [(cons a actions)
-		  (match a
-		    [(routing-update gestalt)
-		     (process-actions actions (extract-active-events gestalt))]
-		    [(quit)
-		     (log-info "run-ground: Terminating by request")
-		     (void)]
-		    [_
-		     (log-warning "run-ground: ignoring useless meta-action ~v" a)
-		     (process-actions actions active-events)])]))])))))
+  (parameterize ((current-ground-event-async-channel (make-async-channel)))
+    (let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '()))
+      (define event-list (cons (current-ground-event-async-channel)
+			       (if inert?
+				   active-events
+				   (cons idle-handler active-events))))
+      (if (null? event-list)
+	  (begin (log-info "run-ground: Terminating because inert")
+		 (void))
+	  (let ((e (apply sync event-list)))
+	    (match (deliver-event e -2 p)
+	      [#f ;; inert
+	       (await-interrupt #t p active-events)]
+	      [(transition new-state actions)
+	       (let process-actions ((actions (flatten actions)) (active-events active-events))
+		 (match actions
+		   ['()
+		    (await-interrupt #f (struct-copy process p [state new-state]) active-events)]
+		   [(cons a actions)
+		    (match a
+		      [(routing-update gestalt)
+		       (process-actions actions (extract-active-events gestalt))]
+		      [(quit)
+		       (log-info "run-ground: Terminating by request")
+		       (void)]
+		      [_
+		       (log-warning "run-ground: ignoring useless meta-action ~v" a)
+		       (process-actions actions active-events)])]))]))))))