syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Steps towards using :pattern/:template in syntax

This commit is contained in:
Tony Garnock-Jones 2021-06-02 13:11:26 +02:00
parent fe6430abfd
commit b77fe3efbc
2 changed files with 54 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
syndicate/go.rkt
View File

@ -17,8 +17,8 @@
(define start-time (current-inexact-milliseconds)) (define start-time (current-inexact-milliseconds))
(define prev-value 0) (define prev-value 0)
(at ds (at ds
(assert (BoxState->preserves (BoxState (value)))) (assert (BoxState (value)))
(when (message (SetBox new-value)) (when (message (SetBox $new-value))
(when (zero? (remainder new-value REPORT_EVERY)) (when (zero? (remainder new-value REPORT_EVERY))
(define end-time (current-inexact-milliseconds)) (define end-time (current-inexact-milliseconds))
(define delta (/ (- end-time start-time) 1000.0)) (define delta (/ (- end-time start-time) 1000.0))
@ -35,7 +35,7 @@
(spawn (define root-facet this-facet) (spawn (define root-facet this-facet)
(define count 0) (define count 0)
(at ds (at ds
(when (asserted (BoxState value)) (when (asserted (BoxState $value))
(send! ds (SetBox->preserves (SetBox (+ value 1))))) (send! ds (SetBox->preserves (SetBox (+ value 1)))))
;; (during (BoxState _) ;; (during (BoxState _)
;; (on-start (set! count (+ count 1))) ;; (on-start (set! count (+ count 1)))
@ -43,8 +43,7 @@
;; (when (zero? count) ;; (when (zero? count)
;; (log-info "Client detected box termination") ;; (log-info "Client detected box termination")
;; (stop-facet root-facet)))) ;; (stop-facet root-facet))))
(assert (Observe->preserves (assert (Observe 'BoxState
(Observe 'BoxState
(ref (entity #:assert (ref (entity #:assert
(action (_v _h) (action (_v _h)
(set! count (+ count 1))) (set! count (+ count 1)))
@ -53,7 +52,7 @@
(set! count (- count 1)) (set! count (- count 1))
(when (zero? count) (when (zero? count)
(log-info "Client detected box termination") (log-info "Client detected box termination")
(stop-facet root-facet)))))))) (stop-facet root-facet)))))))
;; (during (BoxState _) ;; (during (BoxState _)
;; (on-stop (log-info "Client detected box termination") ;; (on-stop (log-info "Client detected box termination")
;; (stop-facet root-facet))) ;; (stop-facet root-facet)))

44
syndicate/syntax.rkt
View File

@ -39,6 +39,7 @@
(require (prefix-in actor: "actor.rkt")) (require (prefix-in actor: "actor.rkt"))
(require "event-expander.rkt") (require "event-expander.rkt")
(require "pattern.rkt")
(define-syntax-parameter this-turn (define-syntax-parameter this-turn
(lambda (stx) (lambda (stx)
@ -134,31 +135,25 @@
(define-event-expander assert (define-event-expander assert
(syntax-rules () (syntax-rules ()
[(_ expr) [(_ expr)
(turn-assert/dataflow! this-turn this-target (action () expr))])) (turn-assert/dataflow! this-turn this-target (action () (:template expr)))]))
(require "schemas/gen/dataspace.rkt") (require "schemas/gen/dataspace.rkt")
(define-event-expander event:when (define-event-expander event:when
(lambda (stx) (lambda (stx)
(syntax-case stx (message asserted) (syntax-case stx (message asserted)
[(_ (message (label fields ...)) expr ...) [(_ (message pat) expr ...)
#`(assert (Observe->preserves #`(assert (Observe (:pattern pat)
(Observe 'label
(ref (entity #:message (ref (entity #:message
(action (rec) (action (bindings)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
[(? eof-object?) (void)] expr ...)))))]
[(label fields ...) [(_ (asserted pat) expr ...)
expr ...])))))))] #`(assert (Observe (:pattern pat)
[(_ (asserted (label fields ...)) expr ...)
#`(assert (Observe->preserves
(Observe 'label
(ref (entity #:assert (ref (entity #:assert
(action (rec handle) (action (bindings _handle)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
[(? eof-object?) (void)] expr ...)))))]))
[(label fields ...)
expr ...])))))))]))
(syntax-rules () (syntax-rules ()
[(_ test expr ...) [(_ test expr ...)
(when test expr ...)])) (when test expr ...)]))
@ -166,15 +161,12 @@
(define-event-expander during (define-event-expander during
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ (label fields ...) expr ...) [(_ pat expr ...)
#`(assert (Observe->preserves #`(assert (Observe (:pattern pat)
(Observe 'label
(ref (let ((assertion-map (make-hash))) (ref (let ((assertion-map (make-hash)))
(entity #:assert (entity #:assert
(action (rec handle) (action (bindings handle)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) (match-define (list #,(analyse-pattern-bindings #'pat)) bindings)
[(? eof-object?) (void)]
[(label fields ...)
(let ((facet (react (let ((facet (react
(facet-prevent-inert-check! this-facet) (facet-prevent-inert-check! this-facet)
expr ...))) expr ...)))
@ -185,7 +177,7 @@
(hash-remove! assertion-map handle) (hash-remove! assertion-map handle)
(stop-facet facet)] (stop-facet facet)]
[_ [_
(error 'during "Duplicate assertion handle ~a" handle)]))])) (error 'during "Duplicate assertion handle ~a" handle)])))
#:retract #:retract
(action (handle) (action (handle)
(match (hash-ref assertion-map handle #f) (match (hash-ref assertion-map handle #f)
@ -195,7 +187,7 @@
(error 'during "Duplicate retraction handle ~a" handle)] (error 'during "Duplicate retraction handle ~a" handle)]
[facet [facet
(hash-remove! assertion-map handle) (hash-remove! assertion-map handle)
(stop-facet facet)]))))))))]))) (stop-facet facet)])))))))])))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;;; Local Variables: ;;; Local Variables: