Support debug-names for bindings
This commit is contained in:
parent
bab1beb5ec
commit
ee6731a9b5
|
@ -54,7 +54,8 @@
|
||||||
;; *both* topic when seen as predicates. The remaining variables are
|
;; *both* topic when seen as predicates. The remaining variables are
|
||||||
;; again to be interpreted as universally quantified.
|
;; again to be interpreted as universally quantified.
|
||||||
|
|
||||||
(struct join-message (member-to-room ;; sync channel
|
(struct join-message (debug-name ;; any
|
||||||
|
member-to-room ;; sync channel
|
||||||
room-to-member ;; sync channel
|
room-to-member ;; sync channel
|
||||||
disconnect-box ;; blocking-box
|
disconnect-box ;; blocking-box
|
||||||
member-thread ;; thread
|
member-thread ;; thread
|
||||||
|
@ -66,7 +67,8 @@
|
||||||
|
|
||||||
(struct room-state (name ch members) #:transparent)
|
(struct room-state (name ch members) #:transparent)
|
||||||
(struct route (local-topic remote-topic remote-binding) #:transparent)
|
(struct route (local-topic remote-topic remote-binding) #:transparent)
|
||||||
(struct binding ([topics #:mutable] ;; set of advertised topics
|
(struct binding (debug-name ;; any
|
||||||
|
[topics #:mutable] ;; set of advertised topics
|
||||||
[flows #:mutable] ;; map from signalled (i.e. non-virtual) flow to ref count
|
[flows #:mutable] ;; map from signalled (i.e. non-virtual) flow to ref count
|
||||||
[routes #:mutable] ;; map from flow to set of route
|
[routes #:mutable] ;; map from flow to set of route
|
||||||
in-ch ;; sync channel
|
in-ch ;; sync channel
|
||||||
|
@ -88,16 +90,18 @@
|
||||||
(thread (lambda () (room-main (room-state name ch '()))))
|
(thread (lambda () (room-main (room-state name ch '()))))
|
||||||
(room name ch))
|
(room name ch))
|
||||||
|
|
||||||
(define (join-room room)
|
(define (join-room room [debug-name-base 'handle])
|
||||||
(make-object membership% (room-ch room)))
|
(make-object membership% (room-ch room) (gensym debug-name-base)))
|
||||||
|
|
||||||
(define membership%
|
(define membership%
|
||||||
(class* object% ()
|
(class* object% ()
|
||||||
(init room-init)
|
(init room-init)
|
||||||
|
(init debug-name-init)
|
||||||
|
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
||||||
(define room room-init)
|
(define room room-init)
|
||||||
|
(define debug-name debug-name-init)
|
||||||
(define names (set)) ;; set of all our advertised topics
|
(define names (set)) ;; set of all our advertised topics
|
||||||
(define flows (set)) ;; set of all current flows
|
(define flows (set)) ;; set of all current flows
|
||||||
(define in-ch (make-channel))
|
(define in-ch (make-channel))
|
||||||
|
@ -111,7 +115,7 @@
|
||||||
(set! connected #f)
|
(set! connected #f)
|
||||||
(set! reason v)
|
(set! reason v)
|
||||||
v)))
|
v)))
|
||||||
(channel-put room (join-message out-ch in-ch disconnect-box
|
(channel-put room (join-message debug-name out-ch in-ch disconnect-box
|
||||||
(current-thread)
|
(current-thread)
|
||||||
(current-thread-exit-status)))
|
(current-thread-exit-status)))
|
||||||
|
|
||||||
|
@ -217,8 +221,9 @@
|
||||||
|
|
||||||
(define ((join-message-handler message) state)
|
(define ((join-message-handler message) state)
|
||||||
(match message
|
(match message
|
||||||
[(join-message in-ch out-ch disconnect-box thread exit-status)
|
[(join-message debug-name in-ch out-ch disconnect-box thread exit-status)
|
||||||
(define b (binding (set)
|
(define b (binding debug-name
|
||||||
|
(set)
|
||||||
(hash)
|
(hash)
|
||||||
(hash)
|
(hash)
|
||||||
in-ch
|
in-ch
|
||||||
|
@ -318,7 +323,7 @@
|
||||||
(set-binding-topics! b (set-remove (binding-topics b) departing-topic))))
|
(set-binding-topics! b (set-remove (binding-topics b) departing-topic))))
|
||||||
|
|
||||||
(define (((handle-binding-message b) message) state)
|
(define (((handle-binding-message b) message) state)
|
||||||
;;(write `(considering ,message from ,(binding-name b))) (newline)
|
;;(write `(considering ,message from ,(binding-debug-name b))) (newline)
|
||||||
(match message
|
(match message
|
||||||
[(leave-message why)
|
[(leave-message why)
|
||||||
(part state b why)]
|
(part state b why)]
|
||||||
|
@ -357,5 +362,5 @@
|
||||||
|
|
||||||
(define (enqueue-message! b message)
|
(define (enqueue-message! b message)
|
||||||
(define qb (binding-queue-box b))
|
(define qb (binding-queue-box b))
|
||||||
;;(write `(enqueued ,message for ,(binding-name b))) (newline)
|
;;(write `(enqueued ,message for ,(binding-debug-name b))) (newline)
|
||||||
(set-box! qb (enqueue (unbox qb) message)))
|
(set-box! qb (enqueue (unbox qb) message)))
|
||||||
|
|
Loading…
Reference in New Issue