Ground; expose deliver-event.

core.rkt

@@ -18,6 +18,7 @@
 	 send
 	 feedback
 	 spawn-world
+	 deliver-event
 	 transition-bind
 	 sequence-transitions)
 
@@ -105,7 +106,7 @@
   (and (queue-empty? (world-event-queue w))
        (queue-empty? (world-process-actions w))))
 
-(define (deliver e pid p)
+(define (deliver-event e pid p)
   (with-handlers ([(lambda (exn) #t)
 		   (lambda (exn)
 		     (log-error "Process ~a died with exception:\n~a" pid (exn->string exn))
@@ -120,7 +121,7 @@
 (define (step-children w)
   (let-values (((w step-taken?)
 		(for/fold ([w w] [step-taken? #f]) (((pid p) (in-hash (world-process-table w))))
-		  (define t (deliver #f pid p))
+		  (define t (deliver-event #f pid p))
 		  (if t
 		      (values (apply-transition pid t w) #t)
 		      (values w step-taken?)))))
@@ -188,7 +189,7 @@
   (for/fold ([w w]) (((pid p) (in-hash (world-process-table w))))
     (define e1 (filter-event e (process-routes p)))
     (if e1
-	(apply-transition pid (deliver e1 pid p) w)
+	(apply-transition pid (deliver-event e1 pid p) w)
 	w)))
 
 (define (world-handle-event e w)

ground.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+
+(require racket/match)
+(require racket/list)
+(require "core.rkt")
+(require "pattern.rkt")
+
+(provide (struct-out event)
+	 run-actor)
+
+(struct event (descriptor values) #:prefab)
+
+(define (event-handler descriptor)
+  (handle-evt descriptor (lambda vs (send (event descriptor vs)))))
+
+(define (extract-active-events routes)
+  (filter-map (lambda (r)
+		(and (route-subscription? r)
+		     (zero? (route-meta-level r))
+		     (zero? (route-level r))
+		     (match (route-pattern r)
+		       [(event descriptor (? wildcard?)) (event-handler descriptor)]
+		       [_ #f])))
+	      routes))
+
+(define idle-handler
+  (handle-evt (system-idle-evt) (lambda _ #f)))
+
+(define (run-actor p)
+  (let await-interrupt ((inert? #f) (p p) (active-events '()))
+    (define event-list (if inert?
+			   active-events
+			   (cons idle-handler active-events)))
+    (define e (apply sync event-list))
+    (log-info "Woke: ~v" e)
+    (match (deliver-event e -1 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 routes)
+	       (process-actions actions (extract-active-events routes))]
+	      [(quit)
+	       (log-info "run-actor: Exiting by request")
+	       (void)]
+	      [_
+	       (log-warning "run-actor: ignoring useless meta-action ~v" a)
+	       (process-actions actions active-events)])]))])))