From cecb261c6b96277906dff5f3616175e1823c418f Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Thu, 21 Jul 2016 18:53:41 -0400
Subject: [PATCH] Introduce level-anchor and level-anchor->meta-level

---
 racket/syndicate/actor-lang.rkt               |  4 ++-
 racket/syndicate/actor.rkt                    |  9 ++----
 racket/syndicate/examples/actor/query-set.rkt | 21 ++++++++-----
 racket/syndicate/hierarchy.rkt                | 30 ++++++++++++++++++-
 4 files changed, 47 insertions(+), 17 deletions(-)

diff --git a/racket/syndicate/actor-lang.rkt b/racket/syndicate/actor-lang.rkt
index dca68c9..751f37f 100644
--- a/racket/syndicate/actor-lang.rkt
+++ b/racket/syndicate/actor-lang.rkt
@@ -5,5 +5,7 @@
                     assert
                     ))
 (require "actor.rkt")
+(require "hierarchy.rkt")
 (provide (all-from-out "lang.rkt")
-         (all-from-out "actor.rkt"))
+         (all-from-out "actor.rkt")
+         (all-from-out "hierarchy.rkt"))
diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt
index 27c4f22..6f051b1 100644
--- a/racket/syndicate/actor.rkt
+++ b/racket/syndicate/actor.rkt
@@ -249,7 +249,7 @@
     (pattern (~seq) #:attr Pred #'#t))
 
   (define-splicing-syntax-class meta-level
-    (pattern (~seq #:meta-level level:integer))
+    (pattern (~seq #:meta-level level:expr))
     (pattern (~seq) #:attr level #'0))
 
   (define-splicing-syntax-class priority
@@ -637,11 +637,6 @@
                                 #`(for [(entry (in-set entry-set))]
                                     #,entry-handler-stx)))])))))
 
-(define-for-syntax (prepend-at-meta-stx stx level)
-  (if (zero? level)
-      stx
-      #`(at-meta #,(prepend-at-meta-stx stx (- level 1)))))
-
 (define-for-syntax (analyze-event outer-expr-stx event-stx terminal? script-stx priority-stx)
   (syntax-parse event-stx
     #:literals [core:message asserted retracted rising-edge]
@@ -657,7 +652,7 @@
                            (define capture-vals
                              (match-value/captures
                               body
-                              #,(prepend-at-meta-stx proj (syntax-e #'L.level))))
+                              (core:prepend-at-meta #,proj L.level)))
                            (and capture-vals
                                 (schedule-script!
                                  #:priority #,priority-stx
diff --git a/racket/syndicate/examples/actor/query-set.rkt b/racket/syndicate/examples/actor/query-set.rkt
index 55d661e..206b14a 100644
--- a/racket/syndicate/examples/actor/query-set.rkt
+++ b/racket/syndicate/examples/actor/query-set.rkt
@@ -56,11 +56,16 @@
        (send! 'dump)
        (forever))
 
-(dataspace (actor #:name 'observer-in-ds
-                  (forever
-                   (assert 'observer-in-ds-ready #:meta-level 1)
-                   (on-start (log-info "observer-in-ds: STARTING"))
-                   (define/query-set items `(item ,$a ,$b) #:meta-level 1 (list a b))
-                   (on (message 'dump #:meta-level 1)
-                       (log-info "observer-in-ds: ~v" (items)))))
-           (forever))
+(let ((anchor (level-anchor)))
+  (dataspace (define LEVEL (level-anchor->meta-level anchor))
+             (log-info "Outer level anchor: ~a" anchor)
+             (log-info "Inner level anchor: ~a" (level-anchor))
+             (log-info "Computed meta-level: ~v" LEVEL)
+             (actor #:name 'observer-in-ds
+                    (forever
+                     (assert 'observer-in-ds-ready #:meta-level LEVEL)
+                     (on-start (log-info "observer-in-ds: STARTING"))
+                     (define/query-set items `(item ,$a ,$b) #:meta-level LEVEL (list a b))
+                     (on (message 'dump #:meta-level LEVEL)
+                         (log-info "observer-in-ds: ~v" (items)))))
+             (forever)))
diff --git a/racket/syndicate/hierarchy.rkt b/racket/syndicate/hierarchy.rkt
index acef897..9f7ff4e 100644
--- a/racket/syndicate/hierarchy.rkt
+++ b/racket/syndicate/hierarchy.rkt
@@ -7,7 +7,9 @@
          target-event
          current-actor-path-rev
          current-actor-path
-         call/extended-actor-path)
+         call/extended-actor-path
+         level-anchor
+         level-anchor->meta-level)
 
 ;; An event destined for a particular node in the actor hierarchy.
 ;; Used to inject events from the outside world.
@@ -34,3 +36,29 @@
 (define (call/extended-actor-path pid thunk)
   (parameterize ((current-actor-path-rev (cons pid (current-actor-path-rev))))
     (thunk)))
+
+;; Retrieves an abstract value to be used with level-anchor->meta-level to compute a
+;; relative meta-level number. Concretely, is the actor path to the current actor's
+;; dataspace.
+;;
+;; TODO: Once dataspaces are split into mux and relay, this will need to change to count
+;; just relay steps.
+(define (level-anchor)
+  (if (null? (current-actor-path-rev)) ;; outside even ground
+      '()
+      (reverse (cdr (current-actor-path-rev)))))
+
+;; Computes the number of nesting levels between the current actor's dataspace and the
+;; dataspace path passed in.
+(define (level-anchor->meta-level anchor)
+  (define ds-path (level-anchor))
+  (let loop ((outer anchor) (inner ds-path))
+    (cond
+      [(null? outer) (length inner)]
+      [(and (pair? inner)
+            (equal? (car outer) (car inner)))
+       (loop (cdr outer) (cdr inner))]
+      [else (error 'level-anchor->meta-level
+                   "Attempt to access dataspace ~a from non-contained dataspace ~a"
+                   anchor
+                   ds-path)])))