stop-when, stop-when-true, when retracted
This commit is contained in:
parent
50f6dfadc0
commit
a23047c26b
|
@ -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 ...)]))
|
||||||
|
|
Loading…
Reference in New Issue