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

stop-when, stop-when-true, when retracted

This commit is contained in:
Tony Garnock-Jones 2021-06-03 22:44:39 +02:00
parent 50f6dfadc0
commit a23047c26b
1 changed files with 26 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
syndicate/syntax.rkt
View File

@ -23,10 +23,12 @@
begin/dataflow begin/dataflow
define/dataflow define/dataflow
stop-when-true
this-target this-target
at at
assert assert
stop-when
(rename-out [event:when when]) (rename-out [event:when when])
during during
during*) during*)
@ -116,6 +118,11 @@
(begin (define-field id #f) (begin (define-field id #f)
(begin/dataflow (id expr)))) (begin/dataflow (id expr))))
(define-syntax-rule (stop-when-true test expr ...)
(begin/dataflow
(when test
(stop-current-facet expr ...))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(define-for-syntax orig-insp (define-for-syntax orig-insp
@ -146,11 +153,16 @@
[(_ expr) [(_ expr)
(turn-assert/dataflow! this-turn this-target (action () (:template expr)))])) (turn-assert/dataflow! this-turn this-target (action () (:template expr)))]))
(define-event-expander stop-when
(syntax-rules ()
[(_ event expr ...)
(event:when event (stop-current-facet 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 retracted)
[(_ (message pat) expr ...) [(_ (message pat) expr ...)
#`(assert (Observe (:pattern pat) #`(assert (Observe (:pattern pat)
(ref (entity #:message (ref (entity #:message
@ -162,7 +174,19 @@
(ref (entity #:assert (ref (entity #:assert
(action (bindings _handle) (action (bindings _handle)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
expr ...)))))])) expr ...)))))]
[(_ (retracted pat) expr ...)
#`(assert (Observe (:pattern pat)
(let ((assertion-map (make-hash)))
(ref (entity #:assert
(action (bindings handle)
(hash-set! assertion-map handle bindings))
#:retract
(action (handle)
(match-define (list #,@(analyse-pattern-bindings #'pat))
(hash-ref assertion-map handle))
(hash-remove! assertion-map handle)
expr ...))))))]))
(syntax-rules () (syntax-rules ()
[(_ test expr ...) [(_ test expr ...)
(when test expr ...)])) (when test expr ...)]))