Progress on syntax veneer

This commit is contained in:
Tony Garnock-Jones 2018-04-08 11:44:32 +01:00
parent e84f2e2e39
commit eb24d566e9
4 changed files with 615 additions and 992 deletions

View File

@ -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
;; it on access.
;; TODO: the field ownership checks during field-ref/field-set! might
;; 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,25 +321,25 @@
(set-actor-root-facet! actor f))
(with-current-facet [ds actor f #f]
(boot-proc))
(schedule-script!* ds (lambda ()
(when (and (facet-live? f)
(or (and parent (not (facet-live? parent)))
(facet-inert? ds f)))
(terminate-facet! ds f)))))
(push-script! ds (lambda ()
(when (and (facet-live? f)
(or (and parent (not (facet-live? parent)))
(facet-inert? ds f)))
(terminate-facet! ds f)))))
(define (facet-inert? ds f)
(and (hash-empty? (facet-endpoints f))
(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,102 +434,103 @@
(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 ()
(dataspace-spawn!
ds
'box
(schedule-script!
(current-dataspace)
(lambda ()
(define current-value (field-handle 'current-value
(generate-id! (current-dataspace))
(facet-actor (current-facet))
0))
(add-endpoint! (current-dataspace)
'stop-when-ten
(lambda ()
(when (= (current-value) 10)
(stop-facet! (current-dataspace)
(current-facet)
(lambda ()
(log-info "box: terminating"))))
(void))
#f)
(add-endpoint! (current-dataspace)
'assert-box-state
(lambda () (box-state (current-value)))
#f)
(add-endpoint! (current-dataspace)
'on-message-set-box
(lambda () (observe (set-box (capture (discard)))))
(skeleton-interest (list struct:set-box #f)
'()
'()
'((0 0))
(capture-facet-context
(lambda (op new-value)
(when (eq? '! op)
(schedule-script!
(current-dataspace)
(lambda ()
(log-info "box: taking on new-value ~v" new-value)
(current-value new-value)))))))))
(set))
(dataspace-spawn!
ds
'client
(lambda ()
(add-endpoint! (current-dataspace)
'stop-when-retracted-observe-set-box
(lambda () (observe (observe (set-box (discard)))))
(skeleton-interest (list struct:observe (list struct:set-box #f))
'()
'()
'()
(capture-facet-context
(lambda (op)
(when (eq? '- op)
(stop-facet!
(current-dataspace)
(current-facet)
(lambda ()
(log-info "client: box has gone"))))))))
(add-endpoint! (current-dataspace)
'on-asserted-box-state
(lambda () (observe (box-state (capture (discard)))))
(skeleton-interest (list struct:box-state #f)
'()
'()
'((0 0))
(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)))))
(dataspace-spawn!
ds
'box
(lambda ()
(define current-value (field-handle 'current-value
(generate-id! (current-dataspace))
(current-actor)
0))
(add-endpoint! (current-dataspace)
'stop-when-ten
(lambda ()
(when (= (current-value) 10)
(stop-facet! (current-dataspace)
(current-facet)
(lambda ()
(log-info "box: terminating"))))
(void))
#f)
(add-endpoint! (current-dataspace)
'assert-box-state
(lambda () (box-state (current-value)))
#f)
(add-endpoint! (current-dataspace)
'on-message-set-box
(lambda () (observe (set-box (capture (discard)))))
(skeleton-interest (list struct:set-box #f)
'()
'()
'((0 0))
(capture-facet-context
(lambda (op new-value)
(when (eq? '! op)
(schedule-script!
(current-dataspace)
(lambda ()
(log-info "box: taking on new-value ~v" new-value)
(current-value new-value)))))))))
(set))
(dataspace-spawn!
ds
'client
(lambda ()
(add-endpoint! (current-dataspace)
'stop-when-retracted-observe-set-box
(lambda () (observe (observe (set-box (discard)))))
(skeleton-interest (list struct:observe (list struct:set-box #f))
'()
'()
'()
(capture-facet-context
(lambda (op)
(when (eq? '- op)
(stop-facet!
(current-dataspace)
(current-facet)
(lambda ()
(log-info "client: box has gone"))))))))
(add-endpoint! (current-dataspace)
'on-asserted-box-state
(lambda () (observe (box-state (capture (discard)))))
(skeleton-interest (list struct:box-state #f)
'()
'()
'((0 0))
(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)

View File

@ -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)

View File

@ -2,16 +2,19 @@
(provide (struct-out discard)
(struct-out capture)
analyse-pattern
desc->key
desc->skeleton-proj
desc->capture-proj
desc->skeleton-stx
desc->assertion-stx)
(require racket/match)
(require racket/struct-info)
(require syntax/stx)
(for-syntax analyse-pattern
desc->key
desc->skeleton-proj
desc->skeleton-stx
desc->capture-proj
desc->capture-names
desc->assertion-stx))
(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/struct-info))
(require (for-syntax syntax/stx))
(struct discard () #:prefab)
(struct capture (detail) #:prefab)
@ -30,96 +33,105 @@
;; The other `SkProj` generates a second `SkKey` which is used as the
;; input to a handler function.
(define (dollar-id? stx)
(and (identifier? stx)
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
(begin-for-syntax
(define (dollar-id? stx)
(and (identifier? stx)
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
(define (undollar stx)
(and (dollar-id? stx)
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
(define (undollar stx)
(and (dollar-id? stx)
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
(define (discard-id? stx)
(and (identifier? stx)
(free-transformer-identifier=? #'_ stx)))
(define (discard-id? stx)
(and (identifier? stx)
(free-transformer-identifier=? #'_ stx)))
(define (id-value stx)
(and (identifier? stx)
(syntax-local-value stx (lambda () #f))))
(define (id-value stx)
(and (identifier? stx)
(syntax-local-value stx (lambda () #f))))
(define (list-id? stx)
(and (identifier? stx)
(free-transformer-identifier=? #'list stx)))
(define (list-id? stx)
(and (identifier? stx)
(free-transformer-identifier=? #'list stx)))
(define (analyse-pattern stx)
(syntax-case stx ($)
[(ctor piece ...)
(struct-info? (id-value #'ctor))
(list* 'compound
(extract-struct-info (id-value #'ctor))
(stx-map analyse-pattern #'(piece ...)))]
[(list piece ...)
(list-id? #'list)
(list* 'compound
'list
(stx-map analyse-pattern #'(piece ...)))]
[id
(dollar-id? #'id)
(list 'capture (undollar #'id) (list 'discard))]
[($ id p)
(list 'capture #'id (analyse-pattern #'p))]
[id
(discard-id? #'id)
(list 'discard)]
[_
(list 'atom stx)]))
(define (analyse-pattern stx)
(syntax-case stx ($)
[(ctor piece ...)
(struct-info? (id-value #'ctor))
(list* 'compound
(extract-struct-info (id-value #'ctor))
(stx-map analyse-pattern #'(piece ...)))]
[(list piece ...)
(list-id? #'list)
(list* 'compound
'list
(stx-map analyse-pattern #'(piece ...)))]
[id
(dollar-id? #'id)
(list 'capture (undollar #'id) (list 'discard))]
[($ id p)
(list 'capture #'id (analyse-pattern #'p))]
[id
(discard-id? #'id)
(list 'discard)]
[_
(list 'atom stx)]))
)
;;---------------------------------------------------------------------------
(define (select-pattern-leaves desc capture-fn atom-fn)
(define (walk-node key-rev desc)
(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 ,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)
(match pieces
['() '()]
[(cons p pieces) (append (walk-node (cons index key-rev) p)
(walk-edge (+ index 1) key-rev pieces))]))
(walk-node '(0) desc))
(define (desc->key desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list atom))))
(define (desc->skeleton-proj desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list (reverse key-rev)))))
(define (desc->skeleton-stx desc)
(match desc
[`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
[`(capture ,_ ,p) (append (capture-fn key-rev) (walk-node key-rev p))]
[`(discard) (list)]
[`(atom ,v) (atom-fn key-rev v)]))
(define (walk-edge index key-rev pieces)
(match pieces
['() '()]
[(cons p pieces) (append (walk-node (cons index key-rev) p)
(walk-edge (+ index 1) key-rev pieces))]))
(walk-node '(0) desc))
[`(compound list ,pieces ...)
#`(list 'list #,@(map desc->skeleton-stx pieces))]
[`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
[`(capture ,_ ,p) (desc->skeleton-stx p)]
[`(discard) #'#f]
[`(atom ,atom-stx) #'#f]))
(define (desc->key desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev atom) (list atom))))
(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->skeleton-proj desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev atom) (list (reverse key-rev)))))
(define (desc->capture-names desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list name-stx))
(lambda (key-rev atom) (list))))
(define (desc->capture-proj 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))]
[`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
[`(capture ,_ ,p) (desc->skeleton-stx p)]
[`(discard) #'#f]
[`(atom ,_) #'#f]))
(define (desc->assertion-stx desc)
(match desc
[`(compound list ,pieces ...)
#`(list #,@(map desc->assertion-stx pieces))]
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(#,ctor #,@(map desc->assertion-stx pieces))]
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
[`(discard) #'(discard)]
[`(atom ,v) v]))
(define (desc->assertion-stx desc)
(match desc
[`(compound list ,pieces ...)
#`(list #,@(map desc->assertion-stx pieces))]
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
#`(#,ctor #,@(map desc->assertion-stx pieces))]
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
[`(discard) #'(discard)]
[`(atom ,v) v]))
)

File diff suppressed because it is too large Load Diff