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

90
syndicate/syntax.rkt
View File

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