From ee6731a9b5272cf13d2cd44fdcaafd6c80cc7248 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sun, 11 Mar 2012 13:06:54 -0400
Subject: [PATCH] Support debug-names for bindings

---
 presence/conversation.rkt | 23 ++++++++++++++---------
 1 file changed, 14 insertions(+), 9 deletions(-)

diff --git a/presence/conversation.rkt b/presence/conversation.rkt
index aea67da..9c52dca 100644
--- a/presence/conversation.rkt
+++ b/presence/conversation.rkt
@@ -54,7 +54,8 @@
 ;; *both* topic when seen as predicates. The remaining variables are
 ;; 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
 		      disconnect-box ;; blocking-box
 		      member-thread ;; thread
@@ -66,7 +67,8 @@
 
 (struct room-state (name ch members) #: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
 		 [routes #:mutable] ;; map from flow to set of route
 		 in-ch ;; sync channel
@@ -88,16 +90,18 @@
   (thread (lambda () (room-main (room-state name ch '()))))
   (room name ch))
 
-(define (join-room room)
-  (make-object membership% (room-ch room)))
+(define (join-room room [debug-name-base 'handle])
+  (make-object membership% (room-ch room) (gensym debug-name-base)))
 
 (define membership%
   (class* object% ()
     (init room-init)
+    (init debug-name-init)
 
     (super-new)
 
     (define room room-init)
+    (define debug-name debug-name-init)
     (define names (set)) ;; set of all our advertised topics
     (define flows (set)) ;; set of all current flows
     (define in-ch (make-channel))
@@ -111,7 +115,7 @@
 					     (set! connected #f)
 					     (set! reason 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-exit-status)))
 
@@ -217,8 +221,9 @@
 
 (define ((join-message-handler message) state)
   (match message
-    [(join-message in-ch out-ch disconnect-box thread exit-status)
-     (define b (binding (set)
+    [(join-message debug-name in-ch out-ch disconnect-box thread exit-status)
+     (define b (binding debug-name
+			(set)
 			(hash)
 			(hash)
 			in-ch
@@ -318,7 +323,7 @@
     (set-binding-topics! b (set-remove (binding-topics b) departing-topic))))
 
 (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
     [(leave-message why)
      (part state b why)]
@@ -357,5 +362,5 @@
 
 (define (enqueue-message! b message)
   (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)))