Progress on syntax veneer
This commit is contained in:
parent
e84f2e2e39
commit
eb24d566e9
|
@ -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)
|
||||
|
|
|
@ -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)
|
|
@ -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]))
|
||||
)
|
||||
|
|
1141
syndicate/syntax.rkt
1141
syndicate/syntax.rkt
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue