Treat #:message separately from #:asserted.
While in principle messages are "instantaneous" assertions, it invites confusion to treat them as such in context of `(object)` because assertions by default spawn nested facets, so it's too easy to accidentally wrap a message handler in an unwanted facet. Being explicit about messages means you never get an unwanted facet wrapper.
This commit is contained in:
parent
d23e264756
commit
0b1e9874d1
|
@ -19,7 +19,7 @@
|
||||||
'setter
|
'setter
|
||||||
(embedded
|
(embedded
|
||||||
(object #:name 'update-handler
|
(object #:name 'update-handler
|
||||||
[#:asserted new-value
|
[#:message new-value
|
||||||
(reporter new-value)
|
(reporter new-value)
|
||||||
(when (= new-value LIMIT) (stop-facet root-facet))
|
(when (= new-value LIMIT) (stop-facet root-facet))
|
||||||
(value new-value)]))))))
|
(value new-value)]))))))
|
||||||
|
@ -49,7 +49,7 @@
|
||||||
(define root-facet this-facet)
|
(define root-facet this-facet)
|
||||||
(define disarm (facet-prevent-inert-check! this-facet))
|
(define disarm (facet-prevent-inert-check! this-facet))
|
||||||
(box (object #:name 'box-boot-handler
|
(box (object #:name 'box-boot-handler
|
||||||
[#:asserted refs
|
[#:message refs
|
||||||
(log-info "refs ~v" refs)
|
(log-info "refs ~v" refs)
|
||||||
(match-define (hash-table ('getter (embedded g))
|
(match-define (hash-table ('getter (embedded g))
|
||||||
('setter (embedded s))) refs)
|
('setter (embedded s))) refs)
|
||||||
|
|
|
@ -75,9 +75,9 @@
|
||||||
(at local-peer
|
(at local-peer
|
||||||
(assert (ActiveSocket-controller
|
(assert (ActiveSocket-controller
|
||||||
(object #:name (list name 'socket)
|
(object #:name (list name 'socket)
|
||||||
[#:asserted (Socket-credit amount mode) (issue-credit amount mode)]
|
[#:message (Socket-credit amount mode) (issue-credit amount mode)]
|
||||||
[#:asserted (Socket-data data mode) (relay data mode)]
|
[#:message (Socket-data data mode) (relay data mode)]
|
||||||
[#:asserted (Socket-eof) (close-output-port o)]))))))))
|
[#:message (Socket-eof) (close-output-port o)]))))))))
|
||||||
|
|
||||||
(define (spawn-inbound ds custodian i o spec)
|
(define (spawn-inbound ds custodian i o spec)
|
||||||
(define name (call-with-values (lambda () (tcp-addresses i #t)) list))
|
(define name (call-with-values (lambda () (tcp-addresses i #t)) list))
|
||||||
|
@ -104,14 +104,14 @@
|
||||||
[#:asserted (ActiveSocket-close message)
|
[#:asserted (ActiveSocket-close message)
|
||||||
(log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
|
(log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
|
||||||
(stop-current-facet)]
|
(stop-current-facet)]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-credit amount mode))
|
[#:message (ActiveSocket-Socket (Socket-credit amount mode))
|
||||||
(if issue-credit
|
(if issue-credit
|
||||||
(issue-credit amount mode)
|
(issue-credit amount mode)
|
||||||
(log-syndicate/drivers/tcp-warning
|
(log-syndicate/drivers/tcp-warning
|
||||||
"Socket-credit ~v/~v ignored because no controller present" amount mode))]
|
"Socket-credit ~v/~v ignored because no controller present" amount mode))]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-data data mode))
|
[#:message (ActiveSocket-Socket (Socket-data data mode))
|
||||||
(relay data mode)]
|
(relay data mode)]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-eof))
|
[#:message (ActiveSocket-Socket (Socket-eof))
|
||||||
(close-output-port o)]))
|
(close-output-port o)]))
|
||||||
(at ds
|
(at ds
|
||||||
(assert (ConnectionPeer handle (TcpRemote (caddr name) (cadddr name))))
|
(assert (ConnectionPeer handle (TcpRemote (caddr name) (cadddr name))))
|
||||||
|
@ -246,9 +246,9 @@
|
||||||
#:retracted
|
#:retracted
|
||||||
(on-disconnected)]
|
(on-disconnected)]
|
||||||
[#:asserted (ActiveSocket-close message) (on-rejected message)]
|
[#:asserted (ActiveSocket-close message) (on-rejected message)]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-credit amount mode)) (on-credit amount mode)]
|
[#:message (ActiveSocket-Socket (Socket-credit amount mode)) (on-credit amount mode)]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-data data mode)) (on-data data mode)]
|
[#:message (ActiveSocket-Socket (Socket-data data mode)) (on-data data mode)]
|
||||||
[#:asserted (ActiveSocket-Socket (Socket-eof)) (on-eof)]))
|
[#:message (ActiveSocket-Socket (Socket-eof)) (on-eof)]))
|
||||||
(at ds (assert (Connection s spec))))
|
(at ds (assert (Connection s spec))))
|
||||||
|
|
||||||
(define (send-credit conn amount mode)
|
(define (send-credit conn amount mode)
|
||||||
|
|
|
@ -92,15 +92,15 @@
|
||||||
[(_ name-stx:<name> handler ...)
|
[(_ name-stx:<name> handler ...)
|
||||||
#`(let ((state (make-hash)))
|
#`(let ((state (make-hash)))
|
||||||
(define name name-stx.N)
|
(define name name-stx.N)
|
||||||
(define (handler-function assertion)
|
(define (handler-function assertion is-message?)
|
||||||
(-object-clauses name assertion [] [handler ...]))
|
(-object-clauses name assertion is-message? [] [handler ...]))
|
||||||
(ref (entity #:name name
|
(ref (entity #:name name
|
||||||
#:assert (lambda (m h) (-object-assert state handler-function m h))
|
#:assert (lambda (m h) (-object-assert state handler-function m h))
|
||||||
#:retract (lambda (h) (-object-retract state h))
|
#:retract (lambda (h) (-object-retract state h))
|
||||||
#:message (lambda (m) (-object-message handler-function m)))))]))
|
#:message (lambda (m) (-object-message handler-function m)))))]))
|
||||||
|
|
||||||
(define (-object-assert state handler-function assertion handle)
|
(define (-object-assert state handler-function assertion handle)
|
||||||
(define k (handler-function assertion))
|
(define k (handler-function assertion #f))
|
||||||
(when k (hash-set! state handle k)))
|
(when k (hash-set! state handle k)))
|
||||||
|
|
||||||
(define (-object-retract state handle)
|
(define (-object-retract state handle)
|
||||||
|
@ -110,44 +110,56 @@
|
||||||
(k)))
|
(k)))
|
||||||
|
|
||||||
(define (-object-message handler-function message)
|
(define (-object-message handler-function message)
|
||||||
(define k (handler-function message))
|
(define k (handler-function message #t))
|
||||||
(when k
|
(when k
|
||||||
(k)))
|
(k)))
|
||||||
|
|
||||||
(define-syntax (-object-clauses stx)
|
(define-syntax (-object-clauses stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ name input [completed ...] [])
|
[(_ name input is-message? [completed ...]
|
||||||
|
[])
|
||||||
#'(match input
|
#'(match input
|
||||||
completed ...
|
completed ...
|
||||||
[_
|
[_
|
||||||
(log-syndicate/object-debug "Unhandled assertion ~v in ~v" input name)
|
(log-syndicate/object-debug "Unhandled ~a ~v in ~v"
|
||||||
|
(if is-message? "message" "assertion")
|
||||||
|
input name)
|
||||||
#f])]
|
#f])]
|
||||||
|
|
||||||
[(_ name input [completed ...] [ [#:spawn pat body ...] more ... ])
|
[(_ name input is-message? [completed ...]
|
||||||
|
[ [#:message pat body+ ...] more ... ])
|
||||||
#'(-object-clauses name
|
#'(-object-clauses name
|
||||||
input
|
input
|
||||||
[completed ...]
|
is-message?
|
||||||
[ [#:during pat (spawn/link body ...)] more ... ])]
|
[ completed ... [(-object-pattern pat) #:when is-message?
|
||||||
|
body+ ... #f] ]
|
||||||
|
[more ...])]
|
||||||
|
|
||||||
[(_ name input [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
|
[(_ name input is-message? [completed ...]
|
||||||
|
[ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
|
||||||
#`(-object-clauses name
|
#`(-object-clauses name
|
||||||
input
|
input
|
||||||
[ completed ... [(-object-pattern pat)
|
is-message?
|
||||||
|
[ completed ... [(-object-pattern pat) #:when (not is-message?)
|
||||||
body+ ...
|
body+ ...
|
||||||
#,(if (null? (syntax->list #'(body- ...)))
|
#,(if (null? (syntax->list #'(body- ...)))
|
||||||
#`#f
|
#`#f
|
||||||
#`(lambda () body- ...))] ]
|
#`(lambda () body- ...))] ]
|
||||||
[more ...])]
|
[more ...])]
|
||||||
|
|
||||||
[(_ name input [completed ...] [ [#:asserted pat body+ ...] more ... ])
|
[(_ name input is-message? [completed ...]
|
||||||
|
[ [#:asserted pat body+ ...] more ... ])
|
||||||
#'(-object-clauses name
|
#'(-object-clauses name
|
||||||
input
|
input
|
||||||
|
is-message?
|
||||||
[completed ...]
|
[completed ...]
|
||||||
[ [#:asserted pat body+ ... #:retracted] more ... ])]
|
[ [#:asserted pat body+ ... #:retracted] more ... ])]
|
||||||
|
|
||||||
[(_ name input [completed ...] [ [pat body ...] more ... ])
|
[(_ name input is-message? [completed ...]
|
||||||
|
[ [pat body ...] more ... ])
|
||||||
#'(-object-clauses name
|
#'(-object-clauses name
|
||||||
input
|
input
|
||||||
|
is-message?
|
||||||
[completed ...]
|
[completed ...]
|
||||||
[ [#:asserted pat
|
[ [#:asserted pat
|
||||||
(define f (react (facet-prevent-inert-check! this-facet) body ...))
|
(define f (react (facet-prevent-inert-check! this-facet) body ...))
|
||||||
|
|
Loading…
Reference in New Issue