Steps toward API usable by syntax layer; beginning of syntax layer, adapted from previous implementation

syndicate/dataspace.rkt

@@ -1,5 +1,7 @@
 #lang racket/base
 
+(provide )
+
 (require syndicate/functional-queue)
 (require syndicate/dataflow)
 (require racket/match)
@@ -23,15 +25,15 @@
 ;; A `Dataspace` is a ... TODO
 
 ;; An `Action` is either `(patch (Deltaof Assertion))` or `(message
-;; Assertion)` or `(spawn BootProc)`.
+;; Assertion)` or `(spawn Any BootProc (Set Assertion))`.
 (struct patch (changes) #:prefab)
 (struct message (body) #:prefab)
-(struct spawn (boot-proc) #:prefab)
+(struct spawn (name boot-proc initial-assertions) #:prefab)
 
 (struct dataspace ([next-id #:mutable] ;; Nat
                    routing-table ;; Skeleton
                    facets ;; (MutableHash FID Facet)
-                   actors ;; (MutableSetof FID)
+                   actors ;; (MutableHash FID Any) ;; maps FID to actor name
                    assertions ;; (Bagof Assertion)
                    dataflow ;; DataflowGraph
                    pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
@@ -116,15 +118,17 @@
 
 ;;---------------------------------------------------------------------------
 
-(define (make-dataspace)
+(define (make-dataspace name boot-proc)
-  (dataspace 0
+  (define ds (dataspace 0
-             (make-empty-skeleton)
+                        (make-empty-skeleton)
-             (make-hash)
+                        (make-hash)
-             (mutable-set)
+                        (make-hash)
-             (make-bag)
+                        (make-bag)
-             (make-dataflow-graph)
+                        (make-dataflow-graph)
-             (make-vector priority-count (make-queue))
+                        (make-vector priority-count (make-queue))
-             (make-queue)))
+                        (make-queue)))
+  (dataspace-spawn! ds name boot-proc (set))
+  ds)
 
 (define (generate-id! ds)
   (let ((id (dataspace-next-id ds)))
@@ -140,19 +144,41 @@
 (define (actor-fid? fid)
   (null? (fid-parent fid)))
 
-(define (add-actor! ds boot-proc)
+(define (fid->actor-fid fid)
+  (if (actor-fid? fid)
+      fid
+      (fid->actor-fid (fid-parent fid))))
+
+(define (fid-ancestor? fid maybe-ancestor)
+  (and (pair? fid) ;; empty fid lists obviously no ancestors at all!
+       (or (equal? fid maybe-ancestor)
+           (fid-ancestor? (cdr fid) maybe-ancestor))))
+
+(define (add-actor! ds name boot-proc initial-assertions)
   (define actor-fid (generate-fid! ds '()))
-  (set-add! (dataspace-actors ds) actor-fid)
+  (hash-set! (dataspace-actors ds) actor-fid name)
-  (add-facet! ds actor-fid boot-proc))
+  (for [(a initial-assertions)]
+    (match (bag-change! (dataspace-assertions ds) a 1)
+      ['absent->present (add-assertion! (dataspace-routing-table ds) a)]
+      ;; 'absent->absent and 'present->absent absurd
+      ['present->present (void)])) ;; i.e. no visible change
+  (add-facet! ds #f actor-fid (lambda ()
+                                (boot-proc)
+                                (for [(a initial-assertions)] (dataspace-retract! ds a)))))
 
 (define (lookup-facet ds fid)
   (hash-ref (dataspace-facets ds) fid #f))
 
-(define-syntax-rule (with-current-facet [ds fid script?] body ...)
+(define-syntax-rule (with-current-facet [ds0 fid0 script?] body ...)
-  (parameterize ((current-dataspace ds)
+  (let ((ds ds0)
-                 (current-facet-id fid)
+        (fid fid0))
-                 (in-script? script?))
+    (parameterize ((current-dataspace ds)
-    body ...))
+                   (current-facet-id fid)
+                   (in-script? script?))
+      (with-handlers ([(lambda (e) (not (exn:break? e)))
+                       (lambda (e) (terminate-actor! ds (fid->actor-fid fid)))]) ;; TODO: tracing
+        body ...
+        (void)))))
 
 (define (capture-facet-context proc)
   (let ((ds (current-dataspace))
@@ -209,8 +235,8 @@
            ['present->present (void)]))] ;; i.e. no visible change
       [(message body)
        (send-assertion! (dataspace-routing-table ds) body)]
-      [(spawn boot-proc)
+      [(spawn name boot-proc initial-assertions)
-       (add-actor! ds boot-proc)]))
+       (add-actor! ds name boot-proc initial-assertions)]))
   (not (null? actions)))
 
 (define (run-scripts! ds)
@@ -221,7 +247,11 @@
   ;; being held elsewhere!
   (or ran-a-script performed-an-action))
 
-(define (add-facet! ds fid boot-proc)
+(define (add-facet! ds where fid boot-proc)
+  (when (and (not (in-script?)) where)
+    (error 'add-facet!
+           "~a: Cannot add facet outside script; are you missing an (on ...)?"
+           where))
   (define parent-fid (fid-parent fid))
   (define f (facet fid
                    (make-hash)
@@ -233,11 +263,11 @@
     (when pf (set-facet-children! pf (set-add (facet-children pf) fid))))
   (with-current-facet [ds fid #f]
     (boot-proc))
-  (schedule-script! ds (lambda ()
+  (schedule-script!* ds (lambda ()
-                         (when (and (facet-live? ds fid)
+                          (when (and (facet-live? ds fid)
-                                    (or (and (pair? parent-fid) (not (facet-live? ds parent-fid)))
+                                     (or (and (pair? parent-fid) (not (facet-live? ds parent-fid)))
-                                        (facet-live-but-inert? ds fid)))
+                                         (facet-live-but-inert? ds fid)))
-                           (terminate-facet! ds fid)))))
+                            (terminate-facet! ds fid)))))
 
 (define (facet-live? ds fid)
   (hash-has-key? (dataspace-facets ds) fid))
@@ -249,9 +279,34 @@
        (set-empty? (facet-children f))))
 
 (define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
-  (define v (dataspace-pending-scripts ds))
+  (schedule-script!* #:priority priority ds (capture-facet-context thunk)))
-  (vector-set! v priority (enqueue (vector-ref v priority) (capture-facet-context thunk))))
 
+(define (schedule-script!* #:priority [priority *normal-priority*] ds thunk)
+  (define v (dataspace-pending-scripts ds))
+  (vector-set! v priority (enqueue (vector-ref v priority) thunk)))
+
+;; Precondition: `f` is the `facet` struct that is/was associated with `fid` in `ds`
+(define (retract-facet-assertions-and-subscriptions! ds fid f)
+  (schedule-script!* ds (lambda ()
+                          (for [((eid ep) (in-hash (facet-endpoints f)))]
+                            (dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid))
+                            (dataspace-retract! ds (endpoint-assertion ep))
+                            (define h (endpoint-handler ep))
+                            (when h (dataspace-unsubscribe! ds h))))))
+
+;; Abruptly terminates an entire actor, without running stop-scripts etc.
+(define (terminate-actor! ds actor-fid)
+  (when (not (actor-fid? actor-fid))
+    (error 'terminate-actor! "Attempt to terminate non-actor FID ~a" actor-fid))
+  (hash-remove! (dataspace-actors ds) actor-fid)
+  (let abort-facet! ((fid actor-fid))
+    (define f (lookup-facet ds fid))
+    (when f
+      (hash-remove! (dataspace-facets ds) fid)
+      (for [(child-fid (in-set (facet-children f)))] (abort-facet! child-fid))
+      (retract-facet-assertions-and-subscriptions! ds fid f))))
+
+;; Cleanly terminates a facet and its children, running stop-scripts etc.
 (define (terminate-facet! ds fid)
   (define f (lookup-facet ds fid))
   (when f
@@ -269,24 +324,20 @@
     ;; Run stop-scripts after terminating children. This means that
     ;; children's stop-scripts run before ours.
     (for [(script (reverse (facet-stop-scripts f)))]
-      (schedule-script! ds script))
+      (schedule-script! ds
+                        (lambda ()
+                          (with-current-facet [ds fid #t]
+                            (script)))))
 
-    (schedule-script!
+    (retract-facet-assertions-and-subscriptions! ds fid f)
-     ds
-     (lambda ()
-       (for [((eid ep) (in-hash (facet-endpoints f)))]
-         (dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid))
-         (dataspace-retract! ds (endpoint-assertion ep))
-         (define h (endpoint-handler ep))
-         (when h (dataspace-unsubscribe! ds h)))))
 
-    (schedule-script!
+    (schedule-script!*
      #:priority *gc-priority*
      ds
      (lambda ()
-       (when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid))
+       (if (pair? parent-fid)
-         (log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid)
+           (when (facet-live-but-inert? ds parent-fid) (terminate-facet! ds parent-fid))
-         (terminate-facet! ds parent-fid))))))
+           (terminate-actor! ds fid))))))
 
 (define (stop-facet! ds fid stop-script)
   (with-current-facet [ds (fid-parent fid) #t] ;; run in parent context wrt terminating facet
@@ -294,6 +345,10 @@
                            (terminate-facet! ds fid)
                            (schedule-script! ds stop-script)))))
 
+(define (add-stop-script! ds script-proc)
+  (define f (lookup-facet ds (current-facet-id)))
+  (when f (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f)))))
+
 (define (add-endpoint! ds where assertion-fn handler)
   (when (in-script?)
     (error 'add-endpoint!
@@ -309,10 +364,13 @@
   (when handler (dataspace-subscribe! ds handler))
   (hash-set! (facet-endpoints (lookup-facet ds fid)) eid ep))
 
+(define (enqueue-action! ds action)
+  (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) action)))
+
 (define (ensure-patch-action! ds)
-  (define old-q (dataspace-pending-actions ds))
+  (let ((q (dataspace-pending-actions ds)))
-  (when (or (queue-empty? old-q) (not (patch? (queue-last old-q))))
+    (when (or (queue-empty? q) (not (patch? (queue-last q))))
-    (set-dataspace-pending-actions! ds (enqueue old-q (patch (make-bag)))))
+      (enqueue-action! ds (patch (make-bag)))))
   (patch-changes (queue-last (dataspace-pending-actions ds))))
 
 (define (dataspace-retract! ds assertion)
@@ -330,7 +388,10 @@
   (add-interest! (dataspace-routing-table ds) h))
 
 (define (dataspace-send! ds body)
-  (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) (message body))))
+  (enqueue-action! ds (message body)))
+
+(define (dataspace-spawn! ds name boot-proc initial-assertions)
+  (enqueue-action! ds (spawn name boot-proc initial-assertions)))
 
 (module+ test
   ;; TODO: move somewhere sensible
@@ -344,82 +405,92 @@
   ;; TODO: move somewhere sensible
   (assertion-struct observe (specification))
 
-  (define ds (make-dataspace))
+  (define ds
-  (add-actor! ds
+    (make-dataspace
-              (lambda ()
+     'ground
-                (define current-value (field-handle 'current-value
+     (lambda ()
-                                                    (generate-id! (current-dataspace))
+       (dataspace-spawn!
-                                                    (current-facet-id)
+        ds
-                                                    0))
+        'box
-                (add-endpoint! (current-dataspace)
+        (lambda ()
-                               'stop-when-ten
+          (define current-value (field-handle 'current-value
-                               (lambda ()
+                                              (generate-id! (current-dataspace))
-                                 (when (= (current-value) 10)
+                                              (fid->actor-fid (current-facet-id))
-                                   (stop-facet! (current-dataspace)
+                                              0))
-                                                (current-facet-id)
+          (add-endpoint! (current-dataspace)
-                                                (lambda ()
+                         'stop-when-ten
-                                                  (log-info "box: terminating"))))
+                         (lambda ()
-                                 (void))
+                           (when (= (current-value) 10)
-                               #f)
+                             (stop-facet! (current-dataspace)
-                (add-endpoint! (current-dataspace)
+                                          (current-facet-id)
-                               'assert-box-state
+                                          (lambda ()
-                               (lambda () (box-state (current-value)))
+                                            (log-info "box: terminating"))))
-                               #f)
+                           (void))
-                (add-endpoint! (current-dataspace)
+                         #f)
-                               'on-message-set-box
+          (add-endpoint! (current-dataspace)
-                               (lambda () (observe (set-box (capture (discard)))))
+                         'assert-box-state
-                               (skeleton-interest (list struct:set-box #f)
+                         (lambda () (box-state (current-value)))
-                                                  '()
+                         #f)
-                                                  '()
+          (add-endpoint! (current-dataspace)
-                                                  '((0 0))
+                         'on-message-set-box
-                                                  (capture-facet-context
+                         (lambda () (observe (set-box (capture (discard)))))
-                                                   (lambda (op new-value)
+                         (skeleton-interest (list struct:set-box #f)
-                                                     (when (eq? '! op)
+                                            '()
-                                                       (schedule-script!
+                                            '()
-                                                        (current-dataspace)
+                                            '((0 0))
-                                                        (lambda ()
+                                            (capture-facet-context
-                                                          (log-info "box: taking on new-value ~v" new-value)
+                                             (lambda (op new-value)
-                                                          (current-value new-value))))))))))
+                                               (when (eq? '! op)
-  (add-actor! ds
+                                                 (schedule-script!
-              (lambda ()
+                                                  (current-dataspace)
-                (add-endpoint! (current-dataspace)
+                                                  (lambda ()
-                               'stop-when-retracted-observe-set-box
+                                                    (log-info "box: taking on new-value ~v" new-value)
-                               (lambda () (observe (observe (set-box (discard)))))
+                                                    (current-value new-value)))))))))
-                               (skeleton-interest (list struct:observe (list struct:set-box #f))
+        (set))
-                                                  '()
+       (dataspace-spawn!
-                                                  '()
+        ds
-                                                  '()
+        'client
-                                                  (capture-facet-context
+        (lambda ()
-                                                   (lambda (op)
+          (add-endpoint! (current-dataspace)
-                                                     (when (eq? '- op)
+                         'stop-when-retracted-observe-set-box
-                                                       (stop-facet!
+                         (lambda () (observe (observe (set-box (discard)))))
-                                                        (current-dataspace)
+                         (skeleton-interest (list struct:observe (list struct:set-box #f))
-                                                        (current-facet-id)
+                                            '()
-                                                        (lambda ()
+                                            '()
-                                                          (log-info "client: box has gone"))))))))
+                                            '()
-                (add-endpoint! (current-dataspace)
+                                            (capture-facet-context
-                               'on-asserted-box-state
+                                             (lambda (op)
-                               (lambda () (observe (box-state (capture (discard)))))
+                                               (when (eq? '- op)
-                               (skeleton-interest (list struct:box-state #f)
+                                                 (stop-facet!
-                                                  '()
+                                                  (current-dataspace)
-                                                  '()
+                                                  (current-facet-id)
-                                                  '((0 0))
+                                                  (lambda ()
-                                                  (capture-facet-context
+                                                    (log-info "client: box has gone"))))))))
-                                                   (lambda (op v)
+          (add-endpoint! (current-dataspace)
-                                                     (when (eq? '+ op)
+                         'on-asserted-box-state
-                                                       (schedule-script!
+                         (lambda () (observe (box-state (capture (discard)))))
-                                                        (current-dataspace)
+                         (skeleton-interest (list struct:box-state #f)
-                                                        (lambda ()
+                                            '()
-                                                          (log-info "client: learned that box's value is now ~v" v)
+                                            '()
-                                                          (dataspace-send! (current-dataspace)
+                                            '((0 0))
-                                                                           (set-box (+ v 1))))))))))))
+                                            (capture-facet-context
+                                             (lambda (op v)
+                                               (when (eq? '+ op)
+                                                 (schedule-script!
+                                                  (current-dataspace)
+                                                  (lambda ()
+                                                    (log-info "client: learned that box's value is now ~v" v)
+                                                    (dataspace-send! (current-dataspace)
+                                                                     (set-box (+ v 1)))))))))))
+        (set)))))
 
   (require racket/pretty)
   ;; (pretty-print ds)
-  (let loop ((i 0))
+  (#;time values
-    ;; (printf "--- i = ~v\n" i)
+   (let loop ((i 0))
-    (when (run-scripts! ds)
+     ;; (printf "--- i = ~v\n" i)
-      ;; (pretty-print ds)
+     (when (run-scripts! ds)
-      (loop (+ i 1))))
+       ;; (pretty-print ds)
+       (loop (+ i 1)))))
   ;; (pretty-print ds)
   )

syndicate/syntax-classes.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+;; Common syntax classes.
+
+(provide (for-syntax assertions
+                     name))
+
+(require racket/set)
+
+(require (for-syntax racket/base))
+(require (for-syntax syntax/parse))
+(require (for-syntax syntax/srcloc))
+
+(begin-for-syntax
+  (define-splicing-syntax-class assertions
+    (pattern (~seq #:assertions [exprs ...]))
+    (pattern (~seq) #:attr (exprs 1) #'()))
+
+  (define-splicing-syntax-class name
+    (pattern (~seq #:name N))
+    (pattern (~seq) #:attr N #'#f)))