From dac24674ad594504859f3560a14236ee2ac67c95 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sat, 24 Mar 2012 15:02:15 -0400
Subject: [PATCH] Meta-actions.

---
 os2.rkt | 45 +++++++++++++++++++++++++++++++--------------
 1 file changed, 31 insertions(+), 14 deletions(-)

diff --git a/os2.rkt b/os2.rkt
index 7d261e9..cc3d47a 100644
--- a/os2.rkt
+++ b/os2.rkt
@@ -16,7 +16,8 @@
 
 ;; A EID is an (arbitrary) VM-unique endpoint identifier. Concretely,
 ;; it's a list of two elements, the first being the endpoint's
-;; process's PID and the second being an integer.
+;; process's PID and the second being an integer. (Except for the
+;; ground-vm, where they're different because there aren't any PIDs.)
 
 ;; One endpoint, one topic.
 
@@ -131,25 +132,26 @@
     (match remaining-actions
       ['() (transition state (quasi-queue->list outbound-actions))]
       [(cons (cons pid action) rest)
-       (if (at-meta-level? action)
-	   (let-values (((state new-actions)
-			 (perform-meta-action pid (at-meta-level-preaction action) state)))
-	     (loop rest state (quasi-enqueue-many new-actions outbound-actions)))
-	   (loop rest (perform-action pid action state) outbound-actions))])))
+       (match action
+	 [(at-meta-level preaction)
+	  (define transformed-preaction (transform-meta-action pid preaction))
+	  (loop rest state (quasi-enqueue-one transformed-preaction outbound-actions))]
+	 [preaction
+	  (loop rest (perform-action pid preaction state) outbound-actions)])])))
 
 (define (run-user-code v)
   ;; TODO: use this hook to find all the bits of code that will need
   ;; with-handlers and crash compensation.
   v)
 
-(define (perform-action pid action state)
-  (match action
-    [(add-role topic handlers k) (do-subscribe pid topic handlers k state)]
+(define (perform-action pid preaction state)
+  (match preaction
+    [(add-role topic hs k) (do-subscribe pid topic hs k state)]
     [(delete-role eid reason) (do-unsubscribe pid eid reason state)]
     [(send-message topic body) (route-and-deliver topic body state)]
     [(spawn thunk k) (do-spawn pid thunk k state)]))
 
-(define (do-subscribe pid topic handlers k state)
+(define (do-subscribe pid topic hs k state)
   (define old-process (hash-ref (vm-processes state) pid))
   (define eid-number (process-next-endpoint-id-number old-process))
   (define new-eid (list pid eid-number))
@@ -164,7 +166,7 @@
 		    (define outbound-flow (refine-topic topic flow-pattern))
 		    (let* ((state (run-trapk state
 					     pid
-					     (handlers-presence handlers)
+					     (handlers-presence hs)
 					     new-eid
 					     inbound-flow))
 			   (state (run-trapk state
@@ -184,7 +186,7 @@
 				    new-eid
 				    (endpoint new-eid
 					      topic
-					      handlers))]))
+					      hs))]))
 
 (define (do-unsubscribe pid eid reason state)
   (define endpoint-to-remove (hash-ref (vm-endpoints state) eid))
@@ -261,5 +263,20 @@
 	       [pending-actions (quasi-enqueue-many (for/list ([a actions]) (cons pid a))
 						    (vm-pending-actions state))]))
 
-(define (perform-meta-action pid preaction state)
-  (error 'perform-meta-action "%%% Not implemented"))
+(define (wrap-trapk pid trapk)
+  (lambda args
+    (lambda (state)
+      (apply run-trapk state pid trapk args))))
+
+(define (transform-meta-action pid preaction)
+  (match preaction
+    [(add-role topic hs k)
+     (add-role topic
+	       (handlers (wrap-trapk pid (handlers-presence hs))
+			 (wrap-trapk pid (handlers-absence hs))
+			 (wrap-trapk pid (handlers-message hs)))
+	       (wrap-trapk pid k))]
+    [(? delete-role?) preaction]
+    [(? send-message?) preaction]
+    [(spawn thunk k)
+     (spawn thunk (wrap-trapk pid k))]))