Steps towards using :pattern/:template in syntax
This commit is contained in:
parent
fe6430abfd
commit
b77fe3efbc
|
@ -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,8 +43,7 @@
|
|||
;; (when (zero? count)
|
||||
;; (log-info "Client detected box termination")
|
||||
;; (stop-facet root-facet))))
|
||||
(assert (Observe->preserves
|
||||
(Observe 'BoxState
|
||||
(assert (Observe 'BoxState
|
||||
(ref (entity #:assert
|
||||
(action (_v _h)
|
||||
(set! count (+ count 1)))
|
||||
|
@ -53,7 +52,7 @@
|
|||
(set! count (- count 1))
|
||||
(when (zero? count)
|
||||
(log-info "Client detected box termination")
|
||||
(stop-facet root-facet))))))))
|
||||
(stop-facet root-facet)))))))
|
||||
;; (during (BoxState _)
|
||||
;; (on-stop (log-info "Client detected box termination")
|
||||
;; (stop-facet root-facet)))
|
||||
|
|
|
@ -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
|
||||
[(_ (message pat) expr ...)
|
||||
#`(assert (Observe (:pattern pat)
|
||||
(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
|
||||
(action (bindings)
|
||||
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
||||
expr ...)))))]
|
||||
[(_ (asserted pat) expr ...)
|
||||
#`(assert (Observe (:pattern pat)
|
||||
(ref (entity #:assert
|
||||
(action (rec handle)
|
||||
(match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec)
|
||||
[(? eof-object?) (void)]
|
||||
[(label fields ...)
|
||||
expr ...])))))))]))
|
||||
(action (bindings _handle)
|
||||
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
|
||||
expr ...)))))]))
|
||||
(syntax-rules ()
|
||||
[(_ test expr ...)
|
||||
(when test expr ...)]))
|
||||
|
@ -166,15 +161,12 @@
|
|||
(define-event-expander during
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (label fields ...) expr ...)
|
||||
#`(assert (Observe->preserves
|
||||
(Observe 'label
|
||||
[(_ pat expr ...)
|
||||
#`(assert (Observe (:pattern pat)
|
||||
(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 ...)
|
||||
(action (bindings handle)
|
||||
(match-define (list #,(analyse-pattern-bindings #'pat)) bindings)
|
||||
(let ((facet (react
|
||||
(facet-prevent-inert-check! this-facet)
|
||||
expr ...)))
|
||||
|
@ -185,7 +177,7 @@
|
|||
(hash-remove! assertion-map handle)
|
||||
(stop-facet facet)]
|
||||
[_
|
||||
(error 'during "Duplicate assertion handle ~a" handle)]))]))
|
||||
(error 'during "Duplicate assertion handle ~a" handle)])))
|
||||
#:retract
|
||||
(action (handle)
|
||||
(match (hash-ref assertion-map handle #f)
|
||||
|
@ -195,7 +187,7 @@
|
|||
(error 'during "Duplicate retraction handle ~a" handle)]
|
||||
[facet
|
||||
(hash-remove! assertion-map handle)
|
||||
(stop-facet facet)]))))))))])))
|
||||
(stop-facet facet)])))))))])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;;; Local Variables:
|
||||
|
|
Loading…
Reference in New Issue