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

27
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,17 +43,16 @@
;; (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))) #:retract
#:retract (action (_h)
(action (_h) (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)))

90
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 (bindings)
(action (rec) (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) expr ...)))))]
[(? eof-object?) (void)] [(_ (asserted pat) expr ...)
[(label fields ...) #`(assert (Observe (:pattern pat)
expr ...])))))))] (ref (entity #:assert
[(_ (asserted (label fields ...)) expr ...) (action (bindings _handle)
#`(assert (Observe->preserves (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
(Observe 'label expr ...)))))]))
(ref (entity #:assert
(action (rec handle)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec)
[(? eof-object?) (void)]
[(label fields ...)
expr ...])))))))]))
(syntax-rules () (syntax-rules ()
[(_ test expr ...) [(_ test expr ...)
(when test expr ...)])) (when test expr ...)]))
@ -166,36 +161,33 @@
(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 (bindings handle)
(action (rec handle) (match-define (list #,(analyse-pattern-bindings #'pat)) bindings)
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) (let ((facet (react
[(? eof-object?) (void)] (facet-prevent-inert-check! this-facet)
[(label fields ...) expr ...)))
(let ((facet (react (match (hash-ref assertion-map handle #f)
(facet-prevent-inert-check! this-facet) [#f
expr ...))) (hash-set! assertion-map handle facet)]
(match (hash-ref assertion-map handle #f) ['dead
[#f (hash-remove! assertion-map handle)
(hash-set! assertion-map handle facet)] (stop-facet facet)]
['dead [_
(hash-remove! assertion-map handle) (error 'during "Duplicate assertion handle ~a" handle)])))
(stop-facet facet)] #:retract
[_ (action (handle)
(error 'during "Duplicate assertion handle ~a" handle)]))])) (match (hash-ref assertion-map handle #f)
#:retract [#f
(action (handle) (hash-set! assertion-map handle 'dead)]
(match (hash-ref assertion-map handle #f) ['dead
[#f (error 'during "Duplicate retraction handle ~a" handle)]
(hash-set! assertion-map handle 'dead)] [facet
['dead (hash-remove! assertion-map handle)
(error 'during "Duplicate retraction handle ~a" handle)] (stop-facet facet)])))))))])))
[facet
(hash-remove! assertion-map handle)
(stop-facet facet)]))))))))])))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;;; Local Variables: ;;; Local Variables: