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
define/dataflow
stop-when-true
this-target
at
assert
stop-when
(rename-out [event:when when])
during
during*)
@ -116,6 +118,11 @@
(begin (define-field id #f)
(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
@ -146,11 +153,16 @@
[(_ 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")
(define-event-expander event:when
(lambda (stx)
(syntax-case stx (message asserted)
(syntax-case stx (message asserted retracted)
[(_ (message pat) expr ...)
#`(assert (Observe (:pattern pat)
(ref (entity #:message
@ -162,7 +174,19 @@
(ref (entity #:assert
(action (bindings _handle)
(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 ()
[(_ test expr ...)
(when test expr ...)]))