Route targeted-events via actor paths

racket/syndicate/core.rkt

@@ -218,10 +218,10 @@
 (define (update-state w pid s)
   (struct-copy dataspace w [states (hash-set (dataspace-states w) pid s)]))
 
-(define (send-event/guard delta pid w)
-  (if (patch-empty? delta)
+(define (send-event/guard e pid w)
+  (if (patch-empty? e)
       w
-      (send-event delta pid w)))
+      (send-event e pid w)))
 
 (define (disable-process pid exn w)
   (when exn
@@ -343,6 +343,7 @@
 (define ((inject-event e) w)
   (transition (match e
                 [#f w]
+                [(? targeted-event?) (enqueue-actions w 'meta (list e))]
                 [(? patch? delta) (enqueue-actions w 'meta (list (lift-patch delta)))]
                 [(message body) (enqueue-actions w 'meta (list (message (at-meta body))))])
               '()))
@@ -399,7 +400,9 @@
          (transition (for/fold [(w w)]
                                [(pid (in-list (mux-route-message (dataspace-mux w) body)))]
                        (send-event m pid w))
-                     '()))]))
+                     '()))]
+    [(targeted-event (cons pid remaining-path) e)
+     (transition (send-event/guard (target-event remaining-path e) pid w) '())]))
 
 (define (create-process w behavior initial-transition name)
   (if (not initial-transition)

racket/syndicate/ground.rkt

@@ -6,6 +6,7 @@
 (require racket/match)
 (require racket/list)
 (require "core.rkt")
+(require "hierarchy.rkt")
 (require "trace.rkt")
 (require "trace/stderr.rkt")
 (require "tset.rkt")
@@ -25,15 +26,15 @@
 
 ;; Any -> Void
 ;; Sends a message at the ground-VM metalevel.
-(define (send-ground-message body)
-  (async-channel-put (current-ground-event-async-channel) (message body)))
+(define (send-ground-message body #:path [path '()])
+  (async-channel-put (current-ground-event-async-channel) (target-event path (message body))))
 
 ;; Patch -> Void
 ;; Injects a patch into the ground-VM metalevel. It will appear to be
 ;; asserted by the environment in general. The obligation is on the caller
 ;; to ensure that patches do not interfere between drivers.
-(define (send-ground-patch p)
-  (async-channel-put (current-ground-event-async-channel) p))
+(define (send-ground-patch p #:path [path '()])
+  (async-channel-put (current-ground-event-async-channel) (target-event path p)))
 
 ;;---------------------------------------------------------------------------
 ;; Communication via RacketEvents

racket/syndicate/hierarchy.rkt

@@ -3,13 +3,22 @@
 ;;  - naming specific actors in traces, or
 ;;  - injecting events from the outside world to specific locations in the tree
 
-(provide current-actor-path-rev
+(provide (struct-out targeted-event)
+         target-event
+         current-actor-path-rev
          current-actor-path
-         call/extended-actor-path
-         gen:actor-hierarchy-node
-         actor-hierarchy-node-deliver)
+         call/extended-actor-path)
 
-(require racket/generic)
+;; An event destined for a particular node in the actor hierarchy.
+;; Used to inject events from the outside world.
+(struct targeted-event (relative-path event) #:prefab)
+
+;; If a non-null path is provided, wraps event in a targeted-event
+;; struct.
+(define (target-event relative-path event)
+  (if (pair? relative-path)
+      (targeted-event relative-path event)
+      event))
 
 ;; Parameterof (Listof Any)
 ;; Path to the active leaf in the process tree. The car end is the
@@ -17,7 +26,7 @@
 (define current-actor-path-rev (make-parameter '()))
 
 ;; Retrieves current-actor-path-rev, but reversed, for use with
-;; actor-hierarchy-node-deliver.
+;; target-event.
 (define (current-actor-path) (reverse (current-actor-path-rev)))
 
 ;; Any (-> Any) -> Any
@@ -25,10 +34,3 @@
 (define (call/extended-actor-path pid thunk)
   (parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev))))
     (thunk)))
-
-;; Generic interface for non-leaf nodes in the hierarchy.
-(define-generics actor-hierarchy-node
-  ;; Deliver an event to a specific node in the hierarchy.
-  (actor-hierarchy-node-deliver actor-hierarchy-node
-                                relative-path
-                                event))

racket/syndicate/trace/stderr.rkt

@@ -8,6 +8,7 @@
 (require racket/exn)
 (require (only-in racket/string string-join))
 (require "../core.rkt")
+(require "../hierarchy.rkt")
 (require "../trace.rkt")
 (require "../mux.rkt")
 (require "../pretty.rkt")
@@ -104,6 +105,10 @@
 	   [#f
 	    (when show-events?
 	      (with-color YELLOW (output "~a is being polled for changes.\n" pidstr)))]
+           [(targeted-event relative-path e)
+            (when show-events?
+              (with-color YELLOW
+                (output "~a is routing an event toward ~a\n" pidstr relative-path)))]
 	   [(? patch? p)
 	    (when (or show-events? show-patch-events?)
 	      (with-color YELLOW
@@ -130,6 +135,10 @@
 	   ['boot
 	    (when (or show-events? show-boot-events?)
 	      (with-color YELLOW (output "~a was booted.\n" pidstr)))]
+           [(targeted-event relative-path e)
+            (when show-events?
+              (with-color YELLOW
+                (output "~a routed an event toward ~a\n" pidstr relative-path)))]
 	   [(? patch? p)
 	    (when (exn-and-not (or show-events? show-patch-events?))
 	      (with-color YELLOW
@@ -177,6 +186,8 @@
               (unless (trie-empty? interests)
                 (output "~a's final interests:\n" pidstr)
                 (pretty-print-trie interests (current-error-port))))]
+           [(? targeted-event?)
+            (void)]
            [(quit-dataspace)
             (with-color BRIGHT-RED
               (output "Process ~a performed a quit-dataspace.\n" pidstr))]