Progress on syntax veneer

imperative/dataspace.rkt

@@ -1,11 +1,52 @@
 #lang racket/base
 
-(provide )
+(provide make-dataspace ;; TODO: how to cleanly provide this?
+         run-scripts! ;; TODO: how to cleanly provide this?
+
+         message-struct
+         assertion-struct
+         (struct-out observe)
+
+         dataspace?
+         generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         actor?
+         actor-id
+         actor-name
+
+         facet?
+         facet-actor
+
+         field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
+         field-handle?
+         field-handle-name
+         field-handle-id
+         field-handle-owner
+         field-handle-value
+
+         current-dataspace
+         current-actor
+         current-facet
+         in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
+         capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         add-facet!
+         stop-facet!
+         add-endpoint!
+         terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         push-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+         ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
+
+         dataspace-spawn! ;; TODO: should this be provided?
+         dataspace-send! ;; TODO: should this be provided?
+         )
 
 (require syndicate/functional-queue)
 (require syndicate/dataflow)
 (require racket/match)
 (require racket/set)
+(require (only-in racket/exn exn->string))
 
 (module+ test (require rackunit))
 
@@ -13,6 +54,13 @@
 (require "pattern.rkt")
 (require "bag.rkt")
 
+;; TODO: move somewhere sensible
+;; Thin veneers over `struct` for declaring intent.
+(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
+(define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
+
+(assertion-struct observe (specification))
+
 ;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
 ;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
 
@@ -65,8 +113,8 @@
   [(define (write-proc e p mode)
      (fprintf p "#<endpoint ~a>" (endpoint-id e)))])
 
-;; TODO: field ownership: record actor (root facet) ID in field, check
+;; TODO: the field ownership checks during field-ref/field-set! might
-;; it on access.
+;; be quite expensive. Are they worth it?
 (struct field-handle (name ;; Symbol
                       id ;; Nat
                       owner ;; Actor
@@ -78,12 +126,20 @@
   #:property prop:procedure
   (case-lambda
     [(f)
+     (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-ref f))
      (dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f)
      (field-handle-value f)]
     [(f v)
+     (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
      (dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f)
      (set-field-handle-value! f v)]))
 
+(define (field-scope-error who f)
+  (error who "Field ~a used out-of-scope; owner = ~a, current = ~a"
+         f
+         (field-handle-owner f)
+         (current-actor)))
+
 ;; Parameterof Dataspace
 (define current-dataspace (make-parameter #f))
 
@@ -173,7 +229,11 @@
                    (current-facet f)
                    (in-script? script?))
       (with-handlers ([(lambda (e) (not (exn:break? e)))
-                       (lambda (e) (terminate-actor! ds a))]) ;; TODO: tracing
+                       (lambda (e)
+                         (log-error "Actor ~a died with exception:\n~a"
+                                    (current-actor)
+                                    (exn->string e))
+                         (terminate-actor! ds a))]) ;; TODO: tracing
         body ...
         (void)))))
 
@@ -261,7 +321,7 @@
       (set-actor-root-facet! actor f))
   (with-current-facet [ds actor f #f]
     (boot-proc))
-  (schedule-script!* ds (lambda ()
+  (push-script! ds (lambda ()
                      (when (and (facet-live? f)
                                 (or (and parent (not (facet-live? parent)))
                                     (facet-inert? ds f)))
@@ -272,14 +332,14 @@
        (set-empty? (facet-children f))))
 
 (define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
-  (schedule-script!* #:priority priority ds (capture-facet-context thunk)))
+  (push-script! #:priority priority ds (capture-facet-context thunk)))
 
-(define (schedule-script!* #:priority [priority *normal-priority*] ds thunk)
+(define (push-script! #:priority [priority *normal-priority*] ds thunk-with-context)
   (define v (dataspace-pending-scripts ds))
-  (vector-set! v priority (enqueue (vector-ref v priority) thunk)))
+  (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
 
 (define (retract-facet-assertions-and-subscriptions! ds f)
-  (schedule-script!* ds (lambda ()
+  (push-script! ds (lambda ()
                           (for [((eid ep) (in-hash (facet-endpoints f)))]
                             (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
                             (dataspace-retract! ds (endpoint-assertion ep))
@@ -318,7 +378,7 @@
 
     (retract-facet-assertions-and-subscriptions! ds f)
 
-    (schedule-script!*
+    (push-script!
      #:priority *gc-priority*
      ds
      (lambda ()
@@ -374,27 +434,28 @@
 (define (dataspace-subscribe! ds h)
   (add-interest! (dataspace-routing-table ds) h))
 
+(define (ensure-in-script! who)
+  (when (not (in-script?))
+    (error who "Attempt to perform action outside script; are you missing an (on ...)?")))
+
 (define (dataspace-send! ds body)
+  (ensure-in-script! 'dataspace-send!)
   (enqueue-action! ds (message body)))
 
 (define (dataspace-spawn! ds name boot-proc initial-assertions)
+  (ensure-in-script! 'dataspace-spawn!)
   (enqueue-action! ds (spawn name boot-proc initial-assertions)))
 
 (module+ test
-  ;; TODO: move somewhere sensible
-  ;; Thin veneers over `struct` for declaring intent.
-  (define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
-  (define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
-
   (message-struct set-box (new-value))
   (assertion-struct box-state (value))
 
-  ;; TODO: move somewhere sensible
-  (assertion-struct observe (specification))
-
   (define ds
     (make-dataspace
      'ground
+     (lambda ()
+       (schedule-script!
+        (current-dataspace)
         (lambda ()
           (dataspace-spawn!
            ds
@@ -402,7 +463,7 @@
            (lambda ()
              (define current-value (field-handle 'current-value
                                                  (generate-id! (current-dataspace))
-                                              (facet-actor (current-facet))
+                                                 (current-actor)
                                                  0))
              (add-endpoint! (current-dataspace)
                             'stop-when-ten
@@ -469,7 +530,7 @@
                                                        (log-info "client: learned that box's value is now ~v" v)
                                                        (dataspace-send! (current-dataspace)
                                                                         (set-box (+ v 1)))))))))))
-        (set)))))
+           (set)))))))
 
   (require racket/pretty)
   ;; (pretty-print ds)

imperative/event-expander.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+
+(require auxiliary-macro-context)
+
+(define-auxiliary-macro-context
+  #:context-name event-expander
+  #:prop-name prop:event-expander
+  #:prop-predicate-name event-expander?
+  #:prop-accessor-name event-expander-proc
+  #:macro-definer-name define-event-expander
+  #:introducer-parameter-name current-event-expander-introducer
+  #:local-introduce-name syntax-local-event-expander-introduce
+  #:expander-id-predicate-name event-expander-id?
+  #:expander-transform-name event-expander-transform)
+
+(provide (for-syntax
+          prop:event-expander
+          event-expander?
+          event-expander-proc
+          syntax-local-event-expander-introduce
+          event-expander-id?
+          event-expander-transform)
+         define-event-expander)

imperative/pattern.rkt

@@ -2,16 +2,19 @@
 
 (provide (struct-out discard)
          (struct-out capture)
-         analyse-pattern
+
+         (for-syntax analyse-pattern
                      desc->key
                      desc->skeleton-proj
-         desc->capture-proj
                      desc->skeleton-stx
-         desc->assertion-stx)
+                     desc->capture-proj
+                     desc->capture-names
+                     desc->assertion-stx))
 
-(require racket/match)
+(require (for-syntax racket/base))
-(require racket/struct-info)
+(require (for-syntax racket/match))
-(require syntax/stx)
+(require (for-syntax racket/struct-info))
+(require (for-syntax syntax/stx))
 
 (struct discard () #:prefab)
 (struct capture (detail) #:prefab)
@@ -30,27 +33,28 @@
 ;; The other `SkProj` generates a second `SkKey` which is used as the
 ;; input to a handler function.
 
-(define (dollar-id? stx)
+(begin-for-syntax
+  (define (dollar-id? stx)
     (and (identifier? stx)
          (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
 
-(define (undollar stx)
+  (define (undollar stx)
     (and (dollar-id? stx)
          (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
 
-(define (discard-id? stx)
+  (define (discard-id? stx)
     (and (identifier? stx)
          (free-transformer-identifier=? #'_ stx)))
 
-(define (id-value stx)
+  (define (id-value stx)
     (and (identifier? stx)
          (syntax-local-value stx (lambda () #f))))
 
-(define (list-id? stx)
+  (define (list-id? stx)
     (and (identifier? stx)
          (free-transformer-identifier=? #'list stx)))
 
-(define (analyse-pattern stx)
+  (define (analyse-pattern stx)
     (syntax-case stx ($)
       [(ctor piece ...)
        (struct-info? (id-value #'ctor))
@@ -72,14 +76,16 @@
        (list 'discard)]
       [_
        (list 'atom stx)]))
+  )
 
 ;;---------------------------------------------------------------------------
 
-(define (select-pattern-leaves desc capture-fn atom-fn)
+(begin-for-syntax
+  (define (select-pattern-leaves desc capture-fn atom-fn)
     (define (walk-node key-rev desc)
       (match desc
         [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
-      [`(capture ,_ ,p) (append (capture-fn key-rev) (walk-node key-rev p))]
+        [`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
         [`(discard) (list)]
         [`(atom ,v) (atom-fn key-rev v)]))
     (define (walk-edge index key-rev pieces)
@@ -89,22 +95,17 @@
                                  (walk-edge (+ index 1) key-rev pieces))]))
     (walk-node '(0) desc))
 
-(define (desc->key desc)
+  (define (desc->key desc)
     (select-pattern-leaves desc
-                         (lambda (key-rev) (list))
+                           (lambda (key-rev name-stx) (list))
                            (lambda (key-rev atom) (list atom))))
 
-(define (desc->skeleton-proj desc)
+  (define (desc->skeleton-proj desc)
     (select-pattern-leaves desc
-                         (lambda (key-rev) (list))
+                           (lambda (key-rev name-stx) (list))
                            (lambda (key-rev atom) (list (reverse key-rev)))))
 
-(define (desc->capture-proj desc)
+  (define (desc->skeleton-stx desc)
-  (select-pattern-leaves desc
-                         (lambda (key-rev) (list (reverse key-rev)))
-                         (lambda (key-rev atom) (list))))
-
-(define (desc->skeleton-stx desc)
     (match desc
       [`(compound list ,pieces ...)
        #`(list 'list #,@(map desc->skeleton-stx pieces))]
@@ -112,9 +113,19 @@
        #`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
       [`(capture ,_ ,p) (desc->skeleton-stx p)]
       [`(discard) #'#f]
-    [`(atom ,_) #'#f]))
+      [`(atom ,atom-stx) #'#f]))
 
-(define (desc->assertion-stx desc)
+  (define (desc->capture-proj desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list (reverse key-rev)))
+                           (lambda (key-rev atom) (list))))
+
+  (define (desc->capture-names desc)
+    (select-pattern-leaves desc
+                           (lambda (key-rev name-stx) (list name-stx))
+                           (lambda (key-rev atom) (list))))
+
+  (define (desc->assertion-stx desc)
     (match desc
       [`(compound list ,pieces ...)
        #`(list #,@(map desc->assertion-stx pieces))]
@@ -123,3 +134,4 @@
       [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
       [`(discard) #'(discard)]
       [`(atom ,v) v]))
+  )