Update to new syntax (documentation not yet updated and does not build)

marketplace/drivers/event-relay.rkt

@@ -7,27 +7,24 @@
 
 (: event-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
 (define (event-relay self-id)
-  (spawn: #:debug-name `(event-relay ,self-id)
+  (name-process `(event-relay ,self-id)
-	  #:parent : ParentState
+    (spawn: #:parent : ParentState
-	  #:child : Void
+	    #:child : Void
-	  (transition/no-state
+	    (transition/no-state
-	    (endpoint: : Void
+	      (observe-publishers: Void (cons ? ?)
-		       #:publisher (cons ? ?) #:observer
+		(match-conversation (cons (? evt? e) _)
-		       #:conversation (cons (? evt? e) _)
+		  (on-presence (begin
-		       #:on-presence (begin
+				 (printf "SUBSCRIBED ~v~n" e)
-				       (printf "SUBSCRIBED ~v~n" e)
+				 (flush-output)
-				       (flush-output)
+				 (at-meta-level: Void
-				       (at-meta-level
+				   (name-endpoint `(event-relay ,self-id ,e)
-					(endpoint: : Void
+				     (subscribe-to-topic: Void (cons e ?)
-						   #:subscriber (cons e ?)
+				       (on-message
-						   #:name `(event-relay ,self-id ,e)
+					[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
-						   [msg
+						    (flush-output)
-						    (begin
+						    (send-message msg))]))))))
-						      (printf "FIRED ~v -> ~v~n" e msg)
+		  (on-absence (begin
-						      (flush-output)
+				(printf "UNSUBSCRIBED ~v~n" e)
-						      (send-message msg))])))
+				(flush-output)
-		       #:on-absence (begin
+				(at-meta-level: Void
-				      (printf "UNSUBSCRIBED ~v~n" e)
+				  (delete-endpoint `(event-relay ,self-id ,e)))))))))))
-				      (flush-output)
-				      (at-meta-level
-				       (delete-endpoint `(event-relay ,self-id ,e))))))))

marketplace/drivers/tcp-bare.rkt

@@ -26,50 +26,52 @@
 (define any-listener (tcp-listener (wild)))
 
 (define (tcp-driver)
-  (spawn #:debug-name 'tcp-driver
+  (name-process 'tcp-driver
-	 #:child
+    (spawn
-   (transition (set)
+     (transition (set)
-     (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
+       (observe-publishers/everything (tcp-channel any-listener any-remote (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
+	     (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
-	       #:on-absence (maybe-forget-socket r active-handles))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
-     (endpoint #:publisher  (tcp-channel any-remote any-listener (wild)) #:everything
+       (observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
+	     (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
-	       #:on-absence (maybe-forget-socket r active-handles))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))
-     (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
+       (observe-publishers (tcp-channel any-handle any-remote (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
+	     (on-presence
-	       #:on-absence (maybe-forget-socket r active-handles))
+	      (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
-     (endpoint #:publisher  (tcp-channel any-remote any-handle (wild)) #:observer
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
-	       #:state active-handles
+       (observe-subscribers (tcp-channel any-handle any-remote (wild))
-	       #:role r
+	 (match-state active-handles
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
+	   (match-conversation c
-	       #:on-absence (maybe-forget-socket r active-handles)))))
+	     (on-presence
+	      (maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
 
 (define tcp (tcp-driver)) ;; pre-instantiated!
 
-(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
+(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
-  (match r
+  (match (list orientation c)
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
      (cond
       [(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
       [(not (ground? local-addr)) (transition active-handles)]
       [(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
       [else
        (transition (set-add active-handles (cons local-addr remote-addr))
-	 (spawn #:debug-name (cons local-addr remote-addr)
+	 (name-process (cons local-addr remote-addr)
-		#:child (driver-fun local-addr remote-addr)))])]))
+	   (spawn (driver-fun local-addr remote-addr))))])]))
 
-;; Role Set<HandleMapping> -> Transition
+;; Orientation Topic Set<HandleMapping> -> Transition
-(define (maybe-forget-socket r active-handles)
+(define (maybe-forget-socket orientation c active-handles)
-  (match r
+  (match (list orientation c)
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
      (cond
       [(ground? remote-addr) (transition active-handles)]
       [(not (ground? local-addr)) (transition active-handles)]
@@ -80,40 +82,40 @@
   (match-define (tcp-listener port) local-addr)
   (define listener (tcp:tcp-listen port 4 #t))
 
-  (define (handle-absence r state)
+  (define (handle-absence orientation c state)
     ;; Hey, what if the presence we need went away between our manager
     ;; spawning us, and us getting to this point? Presence being
     ;; "edge-" rather than "level-triggered" means we'll hang around
     ;; sadly forever, accepting connections to nowhere. TODO
-    (match r
+    (match (list orientation c)
-      [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
+      [(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
-	   (role 'subscriber (tcp-channel remote-addr (== local-addr) _) _))
+	   (list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
        (if (ground? remote-addr)
 	   (transition state)
 	   (transition 'listener-is-closed
 	     (quit)
 	     (when (eq? state 'listener-is-running)
-	       (spawn #:debug-name (list 'tcp-listener-closer local-addr)
+	       (name-process (list 'tcp-listener-closer local-addr)
-		      #:child
+		 (spawn (begin (tcp:tcp-close listener)
-		      (begin (tcp:tcp-close listener)
+			       (transition 'dummy (quit))))))))]))
-			     (transition 'dummy (quit)))))))]))
 
   (transition 'listener-is-running
-    (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
+    (observe-publishers/everything (tcp-channel local-addr any-remote (wild))
-	      #:state state
+      (match-state state
-	      #:role r
+	(match-conversation c
-	      #:on-absence (handle-absence r state))
+	  (on-absence (handle-absence 'publisher c state)))))
-    (endpoint #:publisher  (tcp-channel any-remote local-addr (wild)) #:everything
+    (observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
-	      #:state state
+      (match-state state
-	      #:role r
+	(match-conversation c
-	      #:on-absence (handle-absence r state))
+	  (on-absence (handle-absence 'subscriber c state)))))
-    (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
+    (subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild))
-	      [(cons _ (list cin cout))
+      (on-message
-	       (let-values (((local-hostname local-port remote-hostname remote-port)
+       [(cons _ (list cin cout))
-			     (tcp:tcp-addresses cin #t)))
+	(let-values (((local-hostname local-port remote-hostname remote-port)
-		 (define remote-addr (tcp-address remote-hostname remote-port))
+		      (tcp:tcp-addresses cin #t)))
-		 (spawn #:debug-name (cons local-addr remote-addr)
+	  (define remote-addr (tcp-address remote-hostname remote-port))
-			#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
+	  (name-process (cons local-addr remote-addr)
+	    (spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
 
 ;; TcpAddress TcpAddress -> Transition
 (define (tcp-connection-manager local-addr remote-addr)
@@ -142,33 +144,35 @@
       (when is-open
 	(list (when send-eof?
 		(send-message (tcp-channel remote-addr local-addr eof)))
-	      (spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr)
+	      (name-process (list 'tcp-connection-closer local-addr remote-addr)
-		     #:child
+		(spawn (begin (tcp:tcp-abandon-port cin)
-		     (begin (tcp:tcp-abandon-port cin)
+			      (tcp:tcp-abandon-port cout)
-			    (tcp:tcp-abandon-port cout)
+			      (transition/no-state (quit)))))))
-			    (transition/no-state (quit))))))
       (quit)))
 
   (transition #t ;; open
-    (endpoint #:subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
+    (subscribe-to-topic (cons (read-bytes-avail-evt 4096 cin) (wild))
-	      #:state is-open
+      (match-state is-open
-	      [(cons _ (? eof-object?)) (close-transition is-open #t)]
+	(on-message
-	      [(cons _ (? bytes? bs)) (transition is-open (send-message (tcp-channel remote-addr local-addr bs)))])
+	 [(cons _ (? eof-object?)) (close-transition is-open #t)]
-    (endpoint #:subscriber (cons (eof-evt cin) (wild))
+	 [(cons _ (? bytes? bs)) (transition is-open
-	      #:state is-open
+				   (send-message (tcp-channel remote-addr local-addr bs)))])))
-	      [(cons (? evt?) _) (close-transition is-open #t)])
+    (subscribe-to-topic (cons (eof-evt cin) (wild))
-    (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
+      (match-state is-open
-	      #:state is-open
+	(on-message [(cons (? evt?) _) (close-transition is-open #t)])))
-	      #:on-absence (close-transition is-open #f)
+    (subscribe-to-topic (tcp-channel local-addr remote-addr (wild))
-	      [(tcp-channel (== local-addr) (== remote-addr) subpacket)
+      (match-state is-open
-	       (match subpacket
+	(on-absence (close-transition is-open #f))
-		 [(? eof-object?) (close-transition is-open #f)]
+	(on-message
-		 [(? string? s) (begin (write-string s cout)
+	 [(tcp-channel (== local-addr) (== remote-addr) subpacket)
-				       (flush-output cout)
+	  (match subpacket
-				       (transition is-open))]
+	    [(? eof-object?) (close-transition is-open #f)]
-		 [(? bytes? bs) (begin (write-bytes bs cout)
+	    [(? string? s) (begin (write-string s cout)
-				       (flush-output cout)
+				  (flush-output cout)
-				       (transition is-open))])])
+				  (transition is-open))]
-    (endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
+	    [(? bytes? bs) (begin (write-bytes bs cout)
-	      #:state is-open
+				  (flush-output cout)
-	      #:on-absence (close-transition is-open #f))))
+				  (transition is-open))])])))
+    (publish-on-topic (tcp-channel remote-addr local-addr (wild))
+      (match-state is-open
+	(on-absence (close-transition is-open #f))))))

marketplace/drivers/tcp.rkt

@@ -81,49 +81,51 @@
 ;; Spawn
 ;; Process acting as a TCP socket factory.
 (define (tcp-driver)
-  (spawn #:debug-name 'tcp-driver
+  (name-process 'tcp-driver
-	 #:child
+    (spawn
-   (transition (set)
+     (transition (set)
-     (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
+       (observe-publishers/everything (tcp-channel any-listener any-remote (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
+	     (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
-	       #:on-absence (maybe-forget-socket r active-handles))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
-     (endpoint #:publisher  (tcp-channel any-remote any-listener (wild)) #:everything
+       (observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
+	     (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
-	       #:on-absence (maybe-forget-socket r active-handles))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))
-     (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
+       (observe-publishers (tcp-channel any-handle any-remote (wild))
-	       #:state active-handles
+	 (match-state active-handles
-	       #:role r
+	   (match-conversation c
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
+	     (on-presence
-	       #:on-absence (maybe-forget-socket r active-handles))
+	      (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
-     (endpoint #:publisher  (tcp-channel any-remote any-handle (wild)) #:observer
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
-	       #:state active-handles
+       (observe-subscribers (tcp-channel any-remote any-handle (wild))
-	       #:role r
+	 (match-state active-handles
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
+	   (match-conversation c
-	       #:on-absence (maybe-forget-socket r active-handles)))))
+	     (on-presence
+	      (maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
 
-;; Role Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
+;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
-(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
+(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
-  (match r
+  (match (list orientation c)
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
      (cond
       [(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
       [(not (ground? local-addr)) (transition active-handles)]
       [(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
       [else
        (transition (set-add active-handles (cons local-addr remote-addr))
-	 (spawn #:debug-name (cons local-addr remote-addr)
+	 (name-process (cons local-addr remote-addr)
-		#:child (driver-fun local-addr remote-addr)))])]))
+	   (spawn (driver-fun local-addr remote-addr))))])]))
 
-;; Role Set<HandleMapping> -> Transition
+;; Orientation Topic Set<HandleMapping> -> Transition
-(define (maybe-forget-socket r active-handles)
+(define (maybe-forget-socket orientation c active-handles)
-  (match r
+  (match (list orientation c)
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
      (cond
       [(ground? remote-addr) (transition active-handles)]
       [(not (ground? local-addr)) (transition active-handles)]
@@ -134,40 +136,40 @@
   (match-define (tcp-listener port) local-addr)
   (define listener (tcp:tcp-listen port 4 #t))
 
-  (define (handle-absence r state)
+  (define (handle-absence orientation c state)
     ;; Hey, what if the presence we need went away between our manager
     ;; spawning us, and us getting to this point? Presence being
     ;; "edge-" rather than "level-triggered" means we'll hang around
     ;; sadly forever, accepting connections to nowhere. TODO
-    (match r
+    (match (list orientation c)
-      [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
+      [(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
-	   (role 'subscriber (tcp-channel remote-addr (== local-addr) _) _))
+	   (list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
        (if (ground? remote-addr)
 	   (transition state)
 	   (transition 'listener-is-closed
 	     (quit)
 	     (when (eq? state 'listener-is-running)
-	       (spawn #:debug-name (list 'tcp-listener-closer local-addr)
+	       (name-process (list 'tcp-listener-closer local-addr)
-		      #:child
+		 (spawn (begin (tcp:tcp-close listener)
-		      (begin (tcp:tcp-close listener)
+			     (transition 'dummy (quit))))))))]))
-			     (transition 'dummy (quit)))))))]))
 
   (transition 'listener-is-running
-    (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
+    (observe-publishers/everything (tcp-channel local-addr any-remote (wild))
-	      #:state state
+      (match-state state
-	      #:role r
+	(match-conversation c
-	      #:on-absence (handle-absence r state))
+	  (on-absence (handle-absence 'publisher c state)))))
-    (endpoint #:publisher  (tcp-channel any-remote local-addr (wild)) #:everything
+    (observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
-	      #:state state
+      (match-state state
-	      #:role r
+	(match-conversation c
-	      #:on-absence (handle-absence r state))
+	  (on-absence (handle-absence 'subscriber c state)))))
-    (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
+    (subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild))
-	      [(cons _ (list cin cout))
+      (on-message
-	       (let-values (((local-hostname local-port remote-hostname remote-port)
+       [(cons _ (list cin cout))
-			     (tcp:tcp-addresses cin #t)))
+	(let-values (((local-hostname local-port remote-hostname remote-port)
-		 (define remote-addr (tcp-address remote-hostname remote-port))
+		      (tcp:tcp-addresses cin #t)))
-		 (spawn #:debug-name (cons local-addr remote-addr)
+	  (define remote-addr (tcp-address remote-hostname remote-port))
-			#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
+	  (name-process (cons local-addr remote-addr)
+	    (spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
 
 ;; TcpAddress TcpAddress -> Transition
 (define (tcp-connection-manager local-addr remote-addr)
@@ -185,11 +187,10 @@
       (when (not (eq? state #f))
 	(list (when send-eof?
 		(send-message (tcp-channel remote-addr local-addr eof)))
-	      (spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr)
+	      (name-process (list 'tcp-connection-closer local-addr remote-addr)
-		     #:child
+		(spawn(begin (tcp:tcp-abandon-port cin)
-		     (begin (tcp:tcp-abandon-port cin)
+			     (tcp:tcp-abandon-port cout)
-			    (tcp:tcp-abandon-port cout)
+			     (transition 'dummy (quit)))))))
-			    (transition 'dummy (quit))))))
       (quit)))
   (define (adjust-credit state amount)
     (let ((new-credit (+ (tcp-connection-state-credit state) amount)))
@@ -198,56 +199,62 @@
 	(when (positive? new-credit)
 	  (case (tcp-connection-state-mode state)
 	    [(lines)
-	     (endpoint #:subscriber (cons (read-bytes-line-evt cin 'any) (wild))
+	     (name-endpoint 'inbound-relay
-		       #:name 'inbound-relay
+	       (subscribe-to-topic (cons (read-bytes-line-evt cin 'any) (wild))
-		       #:state state
+		 (match-state state
-	      [(cons _ (? eof-object?))
+		   (on-message
-	       (close-transition state #t)]
+		    [(cons _ (? eof-object?))
-	      [(cons _ (? bytes? bs))
+		     (close-transition state #t)]
-	       (sequence-actions (adjust-credit state -1)
+		    [(cons _ (? bytes? bs))
-				 (send-message (tcp-channel remote-addr local-addr bs)))])]
+		     (sequence-actions (adjust-credit state -1)
+				       (send-message (tcp-channel remote-addr local-addr bs)))]))))]
 	    [(bytes)
-	     (endpoint #:subscriber (cons (read-bytes-evt new-credit cin) (wild))
+	     (name-endpoint 'inbound-relay
-		       #:name 'inbound-relay
+	       (subscribe-to-topic (cons (read-bytes-evt new-credit cin) (wild))
-		       #:state state
+		 (match-state state
-	      [(cons _ (? eof-object?))
+		   (on-message
-	       (close-transition state #t)]
+		    [(cons _ (? eof-object?))
-	      [(cons _ (? bytes? bs))
+		     (close-transition state #t)]
-	       (let ((len (bytes-length bs)))
+		    [(cons _ (? bytes? bs))
-		 (sequence-actions (adjust-credit state (- len))
+		     (let ((len (bytes-length bs)))
-				   (send-message (tcp-channel remote-addr local-addr bs))))])])))))
+		       (sequence-actions (adjust-credit state (- len))
+					 (send-message
+					  (tcp-channel remote-addr local-addr bs))))]))))])))))
   (transition (tcp-connection-state 'bytes 0)
-    (endpoint #:subscriber (cons (eof-evt cin) (wild))
+    (subscribe-to-topic (cons (eof-evt cin) (wild))
-	      #:state state
+      (match-state state
-     [(cons (? evt?) _)
+	(on-message
-      (close-transition state #t)])
+	 [(cons (? evt?) _)
-    (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
+	  (close-transition state #t)])))
-	      #:state state
+    (subscribe-to-topic (tcp-channel local-addr remote-addr (wild))
-	      #:on-absence (close-transition state #f)
+      (match-state state
-     [(tcp-channel (== local-addr) (== remote-addr) subpacket)
+	(on-absence (close-transition state #f))
-      (match subpacket
+	(on-message
-	[(? eof-object?) (close-transition state #f)]
+	 [(tcp-channel (== local-addr) (== remote-addr) subpacket)
-	[(? bytes? bs)
+	  (match subpacket
-	 (define len (bytes-length bs))
+	    [(? eof-object?) (close-transition state #f)]
-	 (write-bytes bs cout)
+	    [(? bytes? bs)
-	 (flush-output cout)
+	     (define len (bytes-length bs))
-	 (transition state (send-tcp-credit local-addr remote-addr len))]
+	     (write-bytes bs cout)
-	[_
+	     (flush-output cout)
-	 (error 'tcp-connection-manager*
+	     (transition state (send-tcp-credit local-addr remote-addr len))]
-		"Publisher on a channel isn't supposed to issue channel control messages")])])
+	    [_
-    (endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
+	     (error 'tcp-connection-manager*
-	      #:state state
+		    "Publisher on a channel isn't supposed to issue channel control messages")])])))
-	      #:on-absence (close-transition state #f)
+    (publish-on-topic (tcp-channel remote-addr local-addr (wild))
-     [(tcp-channel (== remote-addr) (== local-addr) subpacket)
+      (match-state state
-      (match subpacket
+	(on-absence (close-transition state #f))
-	[(tcp-credit amount)
+	(on-message
-	 (if state (adjust-credit state amount) (transition state))]
+	 [(tcp-channel (== remote-addr) (== local-addr) subpacket)
-	[(tcp-mode new-mode)
+	  (match subpacket
-	 ;; Also resets credit to zero.
+	    [(tcp-credit amount)
-	 (if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
+	     (if state (adjust-credit state amount) (transition state))]
-	[_
+	    [(tcp-mode new-mode)
-	 (error 'tcp-connection-manager*
+	     ;; Also resets credit to zero.
-		"Subscriber on a channel may only send channel control messages")])])))
+	     (if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
+	    [_
+	     (error 'tcp-connection-manager*
+		    "Subscriber on a channel may only send channel control messages")])])))))
 
 ;; Spawn
 ;; Debugging aid: produces pretty hex dumps of TCP traffic sent on
@@ -271,8 +278,7 @@
        (write `(TCPOTHER ,other)) (newline)
        (void)]))
 
-  (spawn #:debug-name 'tcp-spy
+  (name-process 'tcp-spy
-	 #:child
+    (spawn (transition 'no-state
-	 (transition 'no-state
+	     (observe-publishers (wild) (on-message [m (display-message m)]))
-	   (endpoint #:subscriber (wild) #:observer [m (display-message m)])
+	     (observe-subscribers (wild) (on-message [m (display-message m)]))))))
-	   (endpoint #:publisher (wild) #:observer [m (display-message m)]))))

marketplace/drivers/timer.rkt

@@ -148,18 +148,18 @@
 ;; events and back.
 (: timer-driver : (All (ParentState) -> (Spawn ParentState)))
 (define (timer-driver)
-  (spawn: #:debug-name 'timer-driver
+  (name-process 'timer-driver
-	  #:parent : ParentState
+    (spawn: #:parent : ParentState
-	  #:child : DriverState
+	    #:child : DriverState
-	  (transition: (driver-state (make-timer-heap)) : DriverState
+	    (transition: (driver-state (make-timer-heap)) : DriverState
-	    (endpoint: state : DriverState
+	      (subscribe-to-topic: DriverState (set-timer-pattern (wild) (wild) (wild))
-		       #:subscriber (set-timer-pattern (wild) (wild) (wild))
+		(match-state state
-		       [(set-timer label msecs 'relative)
+		  (on-message
-			(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
+		   [(set-timer label msecs 'relative)
-		       [(set-timer label msecs 'absolute)
+		    (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
-			(install-timer! state label msecs)])
+		   [(set-timer label msecs 'absolute)
-	    (endpoint: : DriverState
+		    (install-timer! state label msecs)])))
-		       #:publisher (timer-expired-pattern (wild) (wild))))))
+	      (publish-on-topic: DriverState (timer-expired-pattern (wild) (wild)))))))
 
 (: install-timer! : DriverState TimerLabel Real -> (Transition DriverState))
 (define (install-timer! state label deadline)
@@ -172,42 +172,44 @@
   (transition: state : DriverState
     (delete-endpoint 'time-listener)
     (and next
-	 (endpoint: state : DriverState
+	 (name-endpoint 'time-listener
-		    #:subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
+	   (subscribe-to-topic: DriverState (cons (timer-evt (pending-timer-deadline next)) (wild))
-		    #:name 'time-listener
+	     (match-state state
-		    [(cons (? evt?) (? real? now))
+	       (on-message
-		     (let ((to-send (fire-timers! (driver-state-heap state) now)))
+		[(cons (? evt?) (? real? now))
-		     ;; Note: compute to-send before recursing, because of side-effects on heap
+		 (let ((to-send (fire-timers! (driver-state-heap state) now)))
-		       (sequence-actions (transition: state : DriverState)
+		   ;; Note: compute to-send before recursing, because of side-effects on heap
-					 update-time-listener!
+		   (sequence-actions (transition: state : DriverState)
-					 to-send))]))))
+				     update-time-listener!
+				     to-send))])))))))
 
 ;; Process for mapping this-level timer requests to meta-level timer
 ;; requests. Useful when running nested VMs: essentially extends timer
 ;; support up the branches of the VM tree toward the leaves.
 (: timer-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
 (define (timer-relay self-id)
-  (spawn: #:debug-name `(timer-relay ,self-id)
+  (name-process `(timer-relay ,self-id)
-	  #:parent : ParentState
+    (spawn: #:parent : ParentState
-	  #:child : RelayState
+	    #:child : RelayState
-	  (transition: (relay-state 0 (make-immutable-hash '())) : RelayState
+	    (transition: (relay-state 0 (make-immutable-hash '())) : RelayState
-	    (at-meta-level
+	      (at-meta-level: RelayState
-	     (endpoint: (relay-state next-counter active-timers) : RelayState
+		(subscribe-to-topic: RelayState (timer-expired-pattern (wild) (wild))
-			#:subscriber (timer-expired-pattern (wild) (wild))
+		  (match-state (relay-state next-counter active-timers)
-			[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
+		    (on-message
-					now)
+		     [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
-			 (transition: (relay-state next-counter (hash-remove active-timers counter))
+				     now)
-			     : RelayState
+		      (transition: (relay-state next-counter (hash-remove active-timers counter))
-			   (and (hash-has-key? active-timers counter)
+			  : RelayState
-				(send-message (timer-expired (hash-ref active-timers counter)
+			(and (hash-has-key? active-timers counter)
-							     now))))]))
+			     (send-message (timer-expired (hash-ref active-timers counter)
-	    (endpoint: (relay-state next-counter active-timers) : RelayState
+							  now))))]))))
-		       #:subscriber (set-timer-pattern (wild) (wild) (wild))
+	      (subscribe-to-topic: RelayState (set-timer-pattern (wild) (wild) (wild))
-		       [(set-timer label msecs kind)
+		(match-state (relay-state next-counter active-timers)
-			(transition: (relay-state (+ next-counter 1)
+		  (on-message
-						  (hash-set active-timers next-counter label))
+		   [(set-timer label msecs kind)
-			    : RelayState
+		    (transition: (relay-state (+ next-counter 1)
-			  (at-meta-level: : RelayState
+					      (hash-set active-timers next-counter label))
-			    (send-message (set-timer (list self-id next-counter) msecs kind))))])
+			: RelayState
-	    (endpoint: : RelayState
+		      (at-meta-level: RelayState
-		       #:publisher (timer-expired-pattern (wild) (wild))))))
+			(send-message (set-timer (list self-id next-counter) msecs kind))))])))
+	      (publish-on-topic: RelayState (timer-expired-pattern (wild) (wild)))))))

marketplace/drivers/udp.rkt

@@ -133,41 +133,38 @@
       (transition: (set-add active-handles local-addr) : DriverState
 	(udp-socket-manager local-addr))]))
 
-  (spawn: #:debug-name 'udp-driver
+  (name-process 'udp-driver
-	  #:parent : ParentState
+    (spawn: #:parent : ParentState
-	  #:child : DriverState
+	    #:child : DriverState
-	  (transition: ((inst set UdpLocalAddress)) : DriverState
+	    (transition: ((inst set UdpLocalAddress)) : DriverState
-	    (endpoint: active-handles : DriverState
+
-		       #:publisher
+	      (observe-subscribers: DriverState
-		       (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
+		  (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-		       #:observer
+		(match-state active-handles
-		       #:conversation topic
+		  (match-conversation topic
-		       #:on-presence (handle-presence topic active-handles))
+		    (on-presence (handle-presence topic active-handles)))))
-	    (endpoint: active-handles : DriverState
+	      (observe-subscribers: DriverState
-		       #:publisher
+		  (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
-		       (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
+		(match-state active-handles
-		       #:observer
+		  (match-conversation topic
-		       #:conversation topic
+		    (on-presence (handle-presence topic active-handles)))))
-		       #:on-presence (handle-presence topic active-handles))
+	      (observe-publishers: DriverState
-	    (endpoint: active-handles : DriverState
+		  (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-		       #:subscriber
+		(match-state active-handles
-		       (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
+		  (match-conversation topic
-		       #:observer
+		    (on-presence (handle-presence topic active-handles)))))
-		       #:conversation topic
+	      (observe-publishers: DriverState
-		       #:on-presence (handle-presence topic active-handles))
+		  (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
-	    (endpoint: active-handles : DriverState
+		(match-state active-handles
-		       #:subscriber
+		  (match-conversation topic
-		       (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
+		    (on-presence (handle-presence topic active-handles)))))
-		       #:observer
+
-		       #:conversation topic
+	      (observe-publishers: DriverState (handle-mapping-pattern (wild) (wild))
-		       #:on-presence (handle-presence topic active-handles))
+		(match-state active-handles
-	    (endpoint: active-handles : DriverState
+		  (match-conversation (handle-mapping local-addr socket)
-		       #:subscriber (handle-mapping-pattern (wild) (wild))
+		    (on-absence
-		       #:observer
+		     (transition: (set-remove active-handles local-addr) : DriverState)))))
-		       #:conversation (handle-mapping local-addr socket)
+	      ))))
-		       #:on-absence
-		       (transition: (set-remove active-handles local-addr) : DriverState))
-	    )))
 
 (: bind-socket! : UDP-Socket UdpLocalAddress -> Void)
 (define (bind-socket! s local-addr)
@@ -192,43 +189,46 @@
     (transition: #f : SocketManagerState
       (quit)
       (when socket-is-open?
-	(spawn: #:debug-name `(udp-socket-closer ,local-addr)
+	(name-process `(udp-socket-closer ,local-addr)
-		#:parent : SocketManagerState
+	  (spawn: #:parent : SocketManagerState
-		#:child : Void
+		  #:child : Void
-		(begin (udp-close s)
+		  (begin (udp-close s)
-		       (transition: (void) : Void (quit)))))))
+			 (transition: (void) : Void (quit))))))))
 
-  (spawn: #:debug-name `(udp-socket-manager ,local-addr)
+  (name-process `(udp-socket-manager ,local-addr)
-	  #:parent : DriverState
+    (spawn: #:parent : DriverState
-	  #:child : SocketManagerState
+	    #:child : SocketManagerState
-	  (transition: #t : SocketManagerState
+	    (transition: #t : SocketManagerState
-	    ;; Offers a handle-mapping on the local network so that
+	      ;; Offers a handle-mapping on the local network so that
-	    ;; the driver/factory can clean up when this process dies.
+	      ;; the driver/factory can clean up when this process dies.
-	    (endpoint: : SocketManagerState #:publisher (handle-mapping local-addr s))
+	      (publish-on-topic: SocketManagerState (handle-mapping local-addr s))
-	    ;; If our counterparty removes either of their endpoints
+	      ;; If our counterparty removes either of their endpoints
-	    ;; as the subscriber end of the remote-to-local stream or
+	      ;; as the subscriber end of the remote-to-local stream or
-	    ;; the publisher end of the local-to-remote stream, shut
+	      ;; the publisher end of the local-to-remote stream, shut
-	    ;; ourselves down. Also, relay messages published on the
+	      ;; ourselves down. Also, relay messages published on the
-	    ;; local-to-remote stream out on the actual socket.
+	      ;; local-to-remote stream out on the actual socket.
-	    (endpoint: socket-is-open? : SocketManagerState
+	      (publish-on-topic: SocketManagerState
-		       #:publisher (udp-packet-pattern any-remote local-addr (wild))
+		  (udp-packet-pattern any-remote local-addr (wild))
-		       #:on-absence (handle-absence socket-is-open?))
+		(match-state socket-is-open?
-	    (endpoint: socket-is-open? : SocketManagerState
+		  (on-absence (handle-absence socket-is-open?))))
-		       #:subscriber (udp-packet-pattern local-addr any-remote (wild))
+	      (subscribe-to-topic: SocketManagerState
-		       #:on-absence (handle-absence socket-is-open?)
+		  (udp-packet-pattern local-addr any-remote (wild))
-		       [(udp-packet (== local-addr)
+		(match-state socket-is-open?
-				    (udp-remote-address remote-host remote-port)
+		  (on-absence (handle-absence socket-is-open?))
-				    body)
+		  (on-message
-			(begin (udp-send-to s remote-host remote-port body)
+		   [(udp-packet (== local-addr)
-			       (transition: socket-is-open? : SocketManagerState))])
+				(udp-remote-address remote-host remote-port)
-	    ;; Listen for messages arriving on the actual socket using
+				body)
-	    ;; a ground event, and relay them at this level.
+		    (begin (udp-send-to s remote-host remote-port body)
-	    (endpoint: : SocketManagerState
+			   (transition: socket-is-open? : SocketManagerState))])))
-		       #:subscriber (cons (udp-receive!-evt s buffer) (wild))
+	      ;; Listen for messages arriving on the actual socket using
-		       [(cons (? evt?) (list (? exact-integer? packet-length)
+	      ;; a ground event, and relay them at this level.
-					     (? string? remote-host)
+	      (subscribe-to-topic: SocketManagerState (cons (udp-receive!-evt s buffer) (wild))
-					     (? valid-port-number? remote-port)))
+		(on-message
-			(let ((packet (subbytes buffer 0 packet-length)))
+		 [(cons (? evt?) (list (? exact-integer? packet-length)
-			  (send-message (udp-packet (udp-remote-address remote-host remote-port)
+				       (? string? remote-host)
-						    local-addr
+				       (? valid-port-number? remote-port)))
-						    packet)))]))))
+		  (let ((packet (subbytes buffer 0 packet-length)))
+		    (send-message (udp-packet (udp-remote-address remote-host remote-port)
+					      local-addr
+					      packet)))]))))))

marketplace/examples/chat-client.rkt

@@ -4,44 +4,43 @@
 
 ;; Usually it's OK to just use display and friends directly.
 ;; Here we have a console output driver just to show how it's done.
-(spawn #:debug-name 'console-output-driver
+(name-process 'console-output-driver
-       #:child
+  (spawn (transition/no-state
-       (transition/no-state
+	   (subscribe-to-topic (list 'console-output ?)
-	(endpoint #:subscriber (list 'console-output ?)
+	     (on-message [(list 'console-output item)
-		  [(list 'console-output item)
+			  (printf "~a" item)
-		   (begin (printf "~a" item)
+			  (void)])))))
-			  (void))])))
 
-(spawn #:debug-name 'console-input-driver
+(name-process 'console-input-driver
-       #:child
+  (spawn (transition/no-state
-       (transition/no-state
+	   (name-endpoint 'input-relay
-	(endpoint #:publisher (list 'console-input ?)
+	     (publish-on-topic (list 'console-input ?)
-		  #:name 'input-relay
+	       (on-absence
-		  #:on-absence
+		(send-message (list 'console-output "Connection terminated.\n"))
-		  (list (send-message (list 'console-output "Connection terminated.\n"))
+		(quit))))
-			(quit)))
+	   (subscribe-to-topic (cons (read-line-evt (current-input-port) 'any) ?)
-	(endpoint #:subscriber (cons (read-line-evt (current-input-port) 'any) ?)
+	     (on-message
-		  [(cons _ (? eof-object?))
+	      [(cons _ (? eof-object?))
-		   (list (send-message (list 'console-output "Terminating on local EOF.\n"))
+	       (send-message (list 'console-output "Terminating on local EOF.\n"))
-			 (delete-endpoint 'input-relay))]
+	       (delete-endpoint 'input-relay)]
-		  [(cons _ (? string? line))
+	      [(cons _ (? string? line))
-		   (send-message (list 'console-input line))])))
+	       (send-message (list 'console-input line))])))))
 
-(spawn #:debug-name 'outbound-connection
+(name-process 'outbound-connection
-       #:child
+  (spawn (let ((local (tcp-handle 'outbound))
-       (let ((local (tcp-handle 'outbound))
+	       (remote (tcp-address "localhost" 5999)))
-	     (remote (tcp-address "localhost" 5999)))
+	   (transition/no-state
-	 (transition/no-state
+	     (subscribe-to-topic (list 'console-input ?)
-	  (endpoint #:subscriber (list 'console-input ?)
+	       (on-absence (quit))
-		    #:on-absence (quit)
+	       (on-message
-		    [(list 'console-input line)
+		[(list 'console-input line)
-		     (list (send-message (list 'console-output (format "> ~a \n" line)))
+		 (send-message (list 'console-output (format "> ~a \n" line)))
-			   (send-message (tcp-channel local remote (string-append line "\n"))))])
+		 (send-message (tcp-channel local remote (string-append line "\n")))]))
-	  (endpoint #:publisher (tcp-channel local remote ?))
+	     (publish-on-topic (tcp-channel local remote ?))
-	  (endpoint #:subscriber (tcp-channel remote local ?)
+	     (subscribe-to-topic (tcp-channel remote local ?)
-		    #:on-absence (quit)
+	       (on-absence (quit))
-		    [(tcp-channel _ _ (? eof-object?))
+	       (on-message
-		     (quit)]
+		[(tcp-channel _ _ (? eof-object?))
-		    [(tcp-channel _ _ data)
+		 (quit)]
-		     (list (send-message (list 'console-output (format "< ~a" data)))
+		[(tcp-channel _ _ data)
-			   (void))]))))
+		 (send-message (list 'console-output (format "< ~a" data)))]))))))

marketplace/examples/chat-paper-extrasugar.rkt

@@ -1,47 +0,0 @@
-#lang marketplace
-(require "../extrasugar.rkt")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(nested-vm
- (at-meta-level
-  (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
-    (match-conversation (tcp-channel them us _)
-      (on-presence (spawn #:child (chat-session them us)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (chat-session them us)
-  (define user (gensym 'user))
-  (transition stateless
-    (listen-to-user user them us)
-    (speak-to-user user them us)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (listen-to-user user them us)
-  (list
-   (publish-on-topic `(,user says ,?))
-   (at-meta-level
-    (subscribe-to-topic (tcp-channel them us ?)
-      (on-absence (quit))
-      (on-message
-       [(tcp-channel _ _ (? bytes? text))
-        (send-message `(,user says ,text))])))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (speak-to-user user them us)
-  (define (say fmt . args)
-    (at-meta-level
-     (send-message
-      (tcp-channel us them (apply format fmt args)))))
-  (define (announce who did-what)
-    (unless (equal? who user)
-      (say "~s ~s.~n" who did-what)))
-  (list
-   (say "You are ~s.~n" user)
-   (at-meta-level
-    (publish-on-topic (tcp-channel us them ?)))
-   (subscribe-to-topic `(,? says ,?)
-     (match-conversation `(,who says ,_)
-       (on-presence (announce who 'arrived))
-       (on-absence  (announce who 'departed))
-       (on-message [`(,who says ,what)
-                    (say "~a: ~a" who what)])))))

marketplace/examples/chat-paper.rkt

@@ -1,29 +1,31 @@
 #lang marketplace
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (nested-vm
  (at-meta-level
-  (endpoint
+  (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
-   #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
+    (match-conversation (tcp-channel them us _)
-   #:observer
+      (on-presence (spawn (chat-session them us)))))))
-   #:conversation (tcp-channel them us _)
-   #:on-presence
-   (spawn #:child (chat-session them us)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (chat-session them us)
   (define user (gensym 'user))
   (transition stateless
     (listen-to-user user them us)
     (speak-to-user user them us)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (listen-to-user user them us)
   (list
-   (endpoint #:publisher `(,user says ,?))
+   (publish-on-topic `(,user says ,?))
    (at-meta-level
-    (endpoint #:subscriber (tcp-channel them us ?)
+    (subscribe-to-topic (tcp-channel them us ?)
-              #:on-absence (quit)
+      (on-absence (quit))
-              [(tcp-channel _ _ (? bytes? text))
+      (on-message
-               (send-message `(,user says ,text))]))))
+       [(tcp-channel _ _ (? bytes? text))
+        (send-message `(,user says ,text))])))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (speak-to-user user them us)
   (define (say fmt . args)
     (at-meta-level
@@ -35,9 +37,10 @@
   (list
    (say "You are ~s.~n" user)
    (at-meta-level
-    (endpoint #:publisher (tcp-channel us them ?)))
+    (publish-on-topic (tcp-channel us them ?)))
-   (endpoint #:subscriber `(,? says ,?)
+   (subscribe-to-topic `(,? says ,?)
-     #:conversation `(,who says ,_)
+     (match-conversation `(,who says ,_)
-     #:on-presence (announce who 'arrived)
+       (on-presence (announce who 'arrived))
-     #:on-absence  (announce who 'departed)
+       (on-absence  (announce who 'departed))
-     [`(,who says ,what) (say "~a: ~a" who what)])))
+       (on-message [`(,who says ,what)
+                    (say "~a: ~a" who what)])))))

marketplace/examples/debug-chat.rkt

@@ -4,16 +4,12 @@
 
 (debug
  (nested-vm
-  #:debug-name 'echo
   (at-meta-level
-   (endpoint
+   (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
-    #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
+     (match-conversation (tcp-channel them us _)
-    #:observer
+       (on-presence
-    #:conversation (tcp-channel them us _)
+	(debug (name-process (list 'session them)
-    #:on-presence
+		 (spawn (chat-session them us))))))))))
-    (debug
-     (spawn #:debug-name (list 'session them)
-	    #:child (chat-session them us)))))))
 
 (define (chat-session them us)
   (define user (gensym 'user))
@@ -23,12 +19,13 @@
 
 (define (listen-to-user user them us)
   (list
-   (endpoint #:publisher `(,user says ,?))
+   (publish-on-topic `(,user says ,?))
    (at-meta-level
-    (endpoint #:subscriber (tcp-channel them us ?)
+    (subscribe-to-topic (tcp-channel them us ?)
-              #:on-absence (quit)
+      (on-absence (quit))
-              [(tcp-channel _ _ (? bytes? text))
+      (on-message
-               (send-message `(,user says ,text))]))))
+       [(tcp-channel _ _ (? bytes? text))
+        (send-message `(,user says ,text))])))))
 
 (define (speak-to-user user them us)
   (define (say fmt . args)
@@ -41,9 +38,10 @@
   (list
    (say "You are ~s.~n" user)
    (at-meta-level
-    (endpoint #:publisher (tcp-channel us them ?)))
+    (publish-on-topic (tcp-channel us them ?)))
-   (endpoint #:subscriber `(,? says ,?)
+   (subscribe-to-topic `(,? says ,?)
-     #:conversation `(,who says ,_)
+     (match-conversation `(,who says ,_)
-     #:on-presence (announce who 'arrived)
+       (on-presence (announce who 'arrived))
-     #:on-absence  (announce who 'departed)
+       (on-absence  (announce who 'departed))
-     [`(,who says ,what) (say "~a: ~a" who what)])))
+       (on-message [`(,who says ,what)
+                    (say "~a: ~a" who what)])))))

marketplace/examples/echo-paper.rkt

@@ -1,14 +1,13 @@
 #lang marketplace
 
-(endpoint
+(subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?)
- #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
+  (match-conversation (tcp-channel from to _)
- #:conversation (tcp-channel from to _)
+    (on-presence (spawn (echoer from to)))))
- #:on-presence (spawn #:child (echoer from to)))
 
 (define (echoer from to)
   (transition stateless
-    (endpoint
+    (subscribe-to-topic (tcp-channel from to ?)
-      #:subscriber (tcp-channel from to ?)
+      (on-absence (quit))
-      #:on-absence (quit)
+      (on-message
-      [(tcp-channel _ _ data)
+       [(tcp-channel _ _ data)
-       (send-message (tcp-channel to from data))])))
+	(send-message (tcp-channel to from data))]))))

marketplace/examples/echo-plain.rkt

@@ -6,13 +6,13 @@
 
 (define (echoer from to)
   (transition/no-state
-    (endpoint
+    (subscribe-to-topic (tcp-channel from to ?)
-      #:subscriber (tcp-channel from to ?)
+      (on-absence (quit))
-      #:on-absence (quit)
+      (on-message
-      [(tcp-channel _ _ data)
+       [(tcp-channel _ _ data)
-       (send-message (tcp-channel to from data))])))
+	(send-message (tcp-channel to from data))]))))
 
 (ground-vm tcp
-	   (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
+	   (subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?)
-		     #:conversation (tcp-channel from to _)
+	     (match-conversation (tcp-channel from to _)
-		     #:on-presence (spawn #:child (echoer from to))))
+	       (on-presence (spawn (echoer from to))))))

marketplace/sugar-endpoints-typed.rkt

@@ -0,0 +1,257 @@
+#lang typed/racket/base
+
+(require (for-syntax syntax/parse))
+(require (for-syntax racket/base))
+(require "support/dsl-typed.rkt")
+(require (for-syntax "support/dsl-typed.rkt"))
+
+(require racket/match)
+
+(require (prefix-in core: "main.rkt"))
+
+(provide name-endpoint
+	 let-fresh
+	 observe-subscribers:
+	 observe-subscribers/everything:
+	 observe-publishers:
+	 observe-publishers/everything:
+	 publish-on-topic:
+	 subscribe-to-topic:
+	 build-endpoint:)
+
+(define&provide-dsl-helper-syntaxes "endpoint definition context"
+  [match-state
+   match-orientation
+   match-conversation
+   match-interest-type
+   match-reason
+   on-presence
+   on-absence
+   on-message])
+
+;; Must handle:
+;;  - orientation
+;;  - interest-type
+;;  - let-name
+;;  - naming of endpoints
+;;  - state matching
+;;  - conversation (and generally role) matching
+;;  - presence event handling
+;;  - absence event handling (including reason matching)
+;;  - message event handling (including message matching)
+
+(: name-endpoint : (All (State) Any (core:AddEndpoint State) -> (core:AddEndpoint State)))
+(define (name-endpoint n e)
+  (match e
+    [(core:add-endpoint _ role handler)
+     (core:add-endpoint (cast n core:PreEID) role handler)]))
+
+(define-syntax-rule (let-fresh (id ...) exp ...)
+  (let ((id (gensym 'id)) ...) exp ...))
+
+(define-syntax-rule (observe-subscribers: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'publisher (cast topic core:Topic) 'observer)
+		   clause ...))
+
+(define-syntax-rule (observe-subscribers/everything: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'publisher (cast topic core:Topic) 'everything)
+		   clause ...))
+
+(define-syntax-rule (observe-publishers: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'subscriber (cast topic core:Topic) 'observer)
+		   clause ...))
+
+(define-syntax-rule (observe-publishers/everything: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'subscriber (cast topic core:Topic) 'everything)
+		   clause ...))
+
+(define-syntax-rule (publish-on-topic: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'publisher (cast topic core:Topic) 'participant)
+		   clause ...))
+
+(define-syntax-rule (subscribe-to-topic: State topic clause ...)
+  (build-endpoint: State
+		   (gensym 'anonymous-endpoint)
+		   (core:role 'subscriber (cast topic core:Topic) 'participant)
+		   clause ...))
+
+(define-syntax build-endpoint:
+  (lambda (stx)
+    (define (combine-handler-clauses State
+				     clauses-stx
+				     stateful?
+				     state-stx
+				     orientation-stx
+				     conversation-stx
+				     interest-type-stx
+				     reason-stx)
+
+      (define (do-tail new-clauses-stx)
+	(combine-handler-clauses State
+				 new-clauses-stx
+				 stateful?
+				 state-stx
+				 orientation-stx
+				 conversation-stx
+				 interest-type-stx
+				 reason-stx))
+
+      (define (stateful-lift context exprs-stx)
+	(if stateful?
+	    (syntax-case exprs-stx ()
+	      [(expr)
+	       #`(lambda: ([state : #,State]) (match state [#,state-stx expr]))]
+	      [_
+	       (raise-syntax-error #f
+				   (format "Expected exactly one expression resulting in a transition, in ~a handler"
+					   context)
+				   stx
+				   exprs-stx)])
+	    (syntax-case exprs-stx ()
+	      [(expr ...)
+	       #`(lambda: ([state : #,State]) (core:transition state (list expr ...)))])))
+
+      (syntax-case clauses-stx ()
+	[() '()]
+
+	[((maybe-match-state pat-stx inner-clause ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-match-state #'match-state)
+	 (append (combine-handler-clauses State
+					  (syntax (inner-clause ...))
+					  #t
+					  #'pat-stx
+					  orientation-stx
+					  conversation-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-match-orientation pat-stx inner-clause ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-match-orientation #'match-orientation)
+	 (append (combine-handler-clauses State
+					  (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  #'pat-stx
+					  conversation-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-match-conversation pat-stx inner-clause ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-match-conversation #'match-conversation)
+	 (append (combine-handler-clauses State
+					  (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  #'pat-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-match-interest-type pat-stx inner-clause ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-match-interest-type #'match-interest-type)
+	 (append (combine-handler-clauses State
+					  (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  conversation-stx
+					  #'pat-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-match-reason pat-stx inner-clause ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-match-reason #'match-reason)
+	 (append (combine-handler-clauses State
+					  (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  conversation-stx
+					  interest-type-stx
+					  #'pat-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-on-presence expr ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-on-presence #'on-presence)
+	 (cons #`[(core:presence-event (core:role #,orientation-stx
+						  #,conversation-stx
+						  #,interest-type-stx))
+		  #,(stateful-lift 'on-presence (syntax (expr ...)))]
+	       (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-on-absence expr ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-on-absence #'on-absence)
+	 (cons #`[(core:absence-event (core:role #,orientation-stx
+						 #,conversation-stx
+						 #,interest-type-stx)
+				      #,reason-stx)
+		  #,(stateful-lift 'on-absence (syntax (expr ...)))]
+	       (do-tail (syntax (outer-clause ...))))]
+
+	[((maybe-on-message [message-pat expr ...] ...) outer-clause ...)
+	 (literal-identifier=? #'maybe-on-message #'on-message)
+	 (cons #`[(core:message-event (core:role #,orientation-stx
+						 #,conversation-stx
+						 #,interest-type-stx)
+				      message)
+		  (match message
+		    #,@(map (lambda (message-clause)
+			      (syntax-case message-clause ()
+				([message-pat expr ...]
+				 #`[message-pat #,(stateful-lift 'on-message
+								 (syntax (expr ...)))])))
+			    (syntax->list (syntax ([message-pat expr ...] ...))))
+		    [_ (lambda: ([state : #,State]) (core:transition state '()))])]
+	       (do-tail (syntax (outer-clause ...))))]
+
+	[(unknown-clause outer-clause ...)
+	 (raise-syntax-error #f
+			     "Illegal clause in endpoint definition"
+			     stx
+			     #'unknown-clause)]))
+
+    (syntax-case stx ()
+      [(dummy State pre-eid-exp role-exp handler-clause ...)
+       #`(core:add-endpoint (cast pre-eid-exp core:PreEID)
+			    role-exp
+			    (match-lambda
+			     #,@(reverse
+				 (combine-handler-clauses
+				  #'State
+				  (syntax (handler-clause ...))
+				  #f
+				  (syntax old-state)
+				  (syntax _)
+				  (syntax _)
+				  (syntax _)
+				  (syntax _)))
+			     [_ (lambda: ([state : State]) (core:transition state '()))]))])))
+
+;;; Local Variables:
+;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
+;;; eval: (put 'let-fresh 'scheme-indent-function 1)
+;;; eval: (put 'observe-subscribers: 'scheme-indent-function 2)
+;;; eval: (put 'observe-subscribers/everything: 'scheme-indent-function 2)
+;;; eval: (put 'observe-publishers: 'scheme-indent-function 2)
+;;; eval: (put 'observe-publishers/everything: 'scheme-indent-function 2)
+;;; eval: (put 'publish-on-topic: 'scheme-indent-function 2)
+;;; eval: (put 'subscribe-to-topic: 'scheme-indent-function 2)
+;;; eval: (put 'match-state 'scheme-indent-function 1)
+;;; eval: (put 'match-orientation 'scheme-indent-function 1)
+;;; eval: (put 'match-conversation 'scheme-indent-function 1)
+;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
+;;; eval: (put 'match-reason 'scheme-indent-function 1)
+;;; End:

marketplace/sugar-endpoints-untyped.rkt

@@ -2,52 +2,31 @@
 
 (require (for-syntax syntax/parse))
 (require (for-syntax racket/base))
-
+(require "support/dsl-untyped.rkt")
-(require racket/stxparam)
-(require racket/splicing)
 
 (require racket/match)
 
 (require (prefix-in core: "main.rkt"))
-(require (except-in "main.rkt"
-		    at-meta-level
-		    spawn
-		    yield
-		    transition
-		    delete-endpoint
-		    send-message
-		    quit))
-(require "sugar-untyped.rkt")
 
-(provide (except-out (all-from-out "sugar-untyped.rkt") endpoint)
+(provide name-endpoint
-	 (all-from-out "main.rkt")
-	 name-endpoint
 	 let-fresh
 	 observe-subscribers
+	 observe-subscribers/everything
 	 observe-publishers
+	 observe-publishers/everything
 	 publish-on-topic
 	 subscribe-to-topic
 	 build-endpoint)
 
-(define-syntax-rule (define&provide-endpoint-helper-syntaxes identifier ...)
+(define&provide-dsl-helper-syntaxes "endpoint definition context"
-  (begin (provide identifier ...)
+  [match-state
-	 (define-syntax identifier
+   match-orientation
-	   (lambda (stx)
+   match-conversation
-	     (raise-syntax-error #f
+   match-interest-type
-				 (format "Illegal use of ~a outside endpoint definition context"
+   match-reason
-					 'identifier)
+   on-presence
-				 stx)))
+   on-absence
-	 ...))
+   on-message])
-
-(define&provide-endpoint-helper-syntaxes
-  match-state
-  match-orientation
-  match-conversation
-  match-interest-type
-  match-reason
-  on-presence
-  on-absence
-  on-message)
 
 ;; Must handle:
 ;;  - orientation
@@ -73,11 +52,21 @@
 		  (core:role 'publisher topic 'observer)
 		  clause ...))
 
+(define-syntax-rule (observe-subscribers/everything topic clause ...)
+  (build-endpoint (gensym 'anonymous-endpoint)
+		  (core:role 'publisher topic 'everything)
+		  clause ...))
+
 (define-syntax-rule (observe-publishers topic clause ...)
   (build-endpoint (gensym 'anonymous-endpoint)
 		  (core:role 'subscriber topic 'observer)
 		  clause ...))
 
+(define-syntax-rule (observe-publishers/everything topic clause ...)
+  (build-endpoint (gensym 'anonymous-endpoint)
+		  (core:role 'subscriber topic 'everything)
+		  clause ...))
+
 (define-syntax-rule (publish-on-topic topic clause ...)
   (build-endpoint (gensym 'anonymous-endpoint)
 		  (core:role 'publisher topic 'participant)
@@ -107,10 +96,20 @@
 				 interest-type-stx
 				 reason-stx))
 
-      (define (stateful-lift expr-stx)
+      (define (stateful-lift context exprs-stx)
 	(if stateful?
-	    #`(match-lambda [#,state-stx #,expr-stx])
+	    (syntax-case exprs-stx ()
-	    #`(lambda (state) (core:transition state #,expr-stx))))
+	      [(expr)
+	       #`(match-lambda [#,state-stx expr])]
+	      [_
+	       (raise-syntax-error #f
+				   (format "Expected exactly one expression resulting in a transition, in ~a handler"
+					   context)
+				   stx
+				   exprs-stx)])
+	    (syntax-case exprs-stx ()
+	      [(expr ...)
+	       #`(lambda (state) (core:transition state (list expr ...)))])))
 
       (syntax-case clauses-stx (match-state
 				match-orientation
@@ -176,7 +175,7 @@
 	 (cons #`[(core:presence-event (core:role #,orientation-stx
 						  #,conversation-stx
 						  #,interest-type-stx))
-		  #,(stateful-lift (syntax (begin expr ...)))]
+		  #,(stateful-lift 'on-presence (syntax (expr ...)))]
 	       (do-tail (syntax (outer-clause ...))))]
 
 	[((on-absence expr ...) outer-clause ...)
@@ -184,7 +183,7 @@
 						 #,conversation-stx
 						 #,interest-type-stx)
 				      #,reason-stx)
-		  #,(stateful-lift (syntax (begin expr ...)))]
+		  #,(stateful-lift 'on-absence (syntax (expr ...)))]
 	       (do-tail (syntax (outer-clause ...))))]
 
 	[((on-message [message-pat expr ...] ...) outer-clause ...)
@@ -196,10 +195,17 @@
 		    #,@(map (lambda (message-clause)
 			      (syntax-case message-clause ()
 				([message-pat expr ...]
-				 #`[message-pat #,(stateful-lift (syntax (begin expr ...)))])))
+				 #`[message-pat #,(stateful-lift 'on-message
+								 (syntax (expr ...)))])))
 			    (syntax->list (syntax ([message-pat expr ...] ...))))
 		    [_ (lambda (state) (core:transition state '()))])]
-	       (do-tail (syntax (outer-clause ...))))]))
+	       (do-tail (syntax (outer-clause ...))))]
+
+	[(unknown-clause outer-clause ...)
+	 (raise-syntax-error #f
+			     "Illegal clause in endpoint definition"
+			     stx
+			     #'unknown-clause)]))
 
     (syntax-case stx ()
       [(dummy pre-eid-exp role-exp handler-clause ...)
@@ -216,3 +222,19 @@
 				  (syntax _)
 				  (syntax _)))
 			     [_ (lambda (state) (core:transition state '()))]))])))
+
+;;; Local Variables:
+;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
+;;; eval: (put 'let-fresh 'scheme-indent-function 1)
+;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
+;;; eval: (put 'observe-subscribers/everything 'scheme-indent-function 1)
+;;; eval: (put 'observe-publishers 'scheme-indent-function 1)
+;;; eval: (put 'observe-publishers/everything 'scheme-indent-function 1)
+;;; eval: (put 'publish-on-topic 'scheme-indent-function 1)
+;;; eval: (put 'subscribe-to-topic 'scheme-indent-function 1)
+;;; eval: (put 'match-state 'scheme-indent-function 1)
+;;; eval: (put 'match-orientation 'scheme-indent-function 1)
+;;; eval: (put 'match-conversation 'scheme-indent-function 1)
+;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
+;;; eval: (put 'match-reason 'scheme-indent-function 1)
+;;; End:

marketplace/sugar-typed.rkt

@@ -15,14 +15,17 @@
 		    quit
 		    wild))
 (require "sugar-values.rkt")
+(require "sugar-endpoints-typed.rkt")
 
 (provide (all-from-out "sugar-values.rkt")
+	 (all-from-out "sugar-endpoints-typed.rkt")
 	 (all-from-out "main.rkt")
 	 ?
 	 transition:
 	 transition/no-state
-	 endpoint:
 	 spawn:
+	 spawn/continue:
+	 name-process
 	 yield:
 	 at-meta-level:
 	 nested-vm:
@@ -40,132 +43,50 @@
 (define-syntax-rule (transition/no-state action ...)
   (transition: (void) : Void action ...))
 
-(define-syntax endpoint:
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~or (~seq (~literal :) State)
-	       (~seq state-pattern (~literal :) State))
-	  (~or (~seq #:subscriber (~bind [is-subscriber #'#t]))
-	       (~seq #:publisher (~bind [is-publisher #'#t])))
-	  topic-expr
-	  (~or (~seq #:participant (~bind [is-participant #'#t]))
-	       (~seq #:observer (~bind [is-observer #'#t]))
-	       (~seq #:everything (~bind [is-everything #'#t]))
-	       (~seq))
-	  (~or (~optional (~seq #:let-name name-binding)
-			  #:defaults ([name-binding #'n0])
-			  #:name "#:let-name binding for endpoint name")
-	       (~optional (~seq #:name pre-eid) #:name "#:name of endpoint")
-	       (~optional (~seq #:on-presence presence) #:name "#:on-presence handler")
-	       (~optional (~seq #:on-absence absence) #:name "#:on-absence handler")
-
-	       (~optional (~seq #:role role) #:name "#:role")
-	       (~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation")
-	       (~optional (~seq #:conversation conversation) #:name "#:conversation")
-	       (~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type")
-
-	       (~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason"))
-	  ...
-	  [message-pattern clause-body]
-	  ...)
-       (define-syntax-rule (build-handler event-pattern e-attr)
-	 (if (attribute e-attr)
-	     #`([event-pattern
-		 #,(if (attribute state-pattern)
-		       #`(lambda: ([state : State]) (match state [state-pattern e-attr]))
-		       #`(lambda: ([state : State]) ((inst core:transition State) state e-attr)))])
-	     #`([event-pattern (lambda: ([state : State])
-				 (core:transition state '()))])))
-       (define role-pattern
-	 (cond
-	  [(attribute role)
-	   (when (or (attribute orientation)
-		     (attribute conversation)
-		     (attribute interest))
-	     (raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx))
-	   #'role]
-	  [else
-	   #`(core:role #,(if (attribute orientation) #'orientation #'_)
-			#,(if (attribute conversation) #'conversation #'_)
-			#,(if (attribute interest) #'interest #'_))]))
-       #`(let ((name-binding (cast #,(if (attribute pre-eid)
-					 #'pre-eid
-					 #'(gensym 'anonymous-endpoint))
-				   core:PreEID)))
-	   (core:add-endpoint
-	    name-binding
-	    (core:role #,(cond
-			  [(attribute is-subscriber) #''subscriber]
-			  [(attribute is-publisher) #''publisher]
-			  [else (raise-syntax-error #f
-						    "Missing #:subscriber or #:publisher"
-						    stx)])
-		       (cast topic-expr core:Topic)
-		       #,(cond
-			  [(attribute is-participant) #''participant]
-			  [(attribute is-observer) #''observer]
-			  [(attribute is-everything) #''everything]
-			  [else #''participant]))
-	    (match-lambda
-	     #,@(build-handler (core:presence-event #,role-pattern) presence)
-	     #,@(build-handler (core:absence-event #,role-pattern reason) absence)
-	     [(core:message-event #,role-pattern message)
-	      #,(if (attribute state-pattern)
-		    #`(lambda: ([state : State])
-			(match state
-			  [state-pattern
-			   (match message
-			     [message-pattern clause-body] ...
-			     [_ (core:transition state '())])]))
-		    #`(lambda: ([state : State])
-			((inst core:transition State)
-			 state
-			 (match message
-			   [message-pattern clause-body] ...
-			   [_ '()]))))]
-	     [_
-	      (lambda: ([state : State]) (core:transition state '()))])))])))
-
 (define-syntax spawn:
   (lambda (stx)
     (syntax-parse stx
-      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
-	       (~optional (~seq #:debug-name debug-name)
+	  #:parent (~literal :) ParentState
-			  #:defaults ([debug-name #'#f])
-			  #:name "#:debug-name")) ...
-	  (~or (~seq #:parent parent-state-pattern (~literal :) ParentState
-		     (~and (~not #:child) parent-k-exp))
-	       (~seq #:parent (~literal :) ParentState
-		     (~and (~not #:child) parent-k-exp))
-	       (~seq #:parent (~literal :) ParentState))
 	  #:child (~literal :) State exp)
        #`((inst core:spawn ParentState)
-	  (core:process-spec (lambda (pid)
+	  (core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
-			       (lambda (k) ((inst k State) exp))))
+	  #f
-	  #,(if (attribute parent-k-exp)
+	  #f)])))
-		(if (attribute parent-state-pattern)
+
-		    #`(lambda (pid)
+(define-syntax spawn/continue:
-			(lambda: ([parent-state : ParentState])
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
+	  #:parent parent-state-pattern (~literal :) ParentState parent-k-exp
+	  #:child (~literal :) State exp)
+       #`((inst core:spawn ParentState)
+	  (core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
+	  (lambda (pid) (lambda: ([parent-state : ParentState])
 			  (match parent-state [parent-state-pattern parent-k-exp])))
-		    #`(lambda (pid)
+	  #f)])))
-			(lambda: ([parent-state : ParentState])
+
-			  ((inst core:transition ParentState) parent-state parent-k-exp))))
+(: name-process : (All (State) Any (core:Spawn State) -> (core:Spawn State)))
-		#'#f)
+(define (name-process n p)
-	  debug-name)])))
+  (match p
+    [(core:spawn spec parent-k _)
+     (core:spawn spec parent-k n)]))
 
 (define-syntax yield:
   (lambda (stx)
     (syntax-case stx (:)
       [(_ state-pattern : State exp)
-       #'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))]
+       #'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))])))
-      [(_ : State exp)
-       #'((inst core:yield State) (lambda (state) (core:transition state exp)))])))
 
 (define-syntax at-meta-level:
   (lambda (stx)
-    (syntax-case stx (:)
+    (syntax-case stx ()
-      [(_ : State preaction ...)
+      [(_ State)
-       #'((inst at-meta-level State) preaction ...)])))
+       #''()]
+      [(_ State preaction)
+       #'((inst core:at-meta-level State) preaction)]
+      [(_ State preaction ...)
+       #'(list ((inst core:at-meta-level State) preaction) ...)])))
 
 (define-syntax nested-vm:
   (lambda (stx)
@@ -208,5 +129,5 @@
 							     (list exp ...)))))))])))
 
 ;;; Local Variables:
-;;; eval: (put 'at-meta-level: 'scheme-indent-function 2)
+;;; eval: (put 'at-meta-level: 'scheme-indent-function 1)
 ;;; End:

marketplace/sugar-untyped.rkt

@@ -14,14 +14,18 @@
 		    send-message
 		    quit))
 (require "sugar-values.rkt")
+(require "sugar-endpoints-untyped.rkt")
 
 (provide (all-from-out "sugar-values.rkt")
+	 (all-from-out "sugar-endpoints-untyped.rkt")
 	 (all-from-out "main.rkt")
 	 ?
 	 transition/no-state
-	 endpoint
 	 spawn
+	 spawn/continue
+	 name-process
 	 yield
+	 at-meta-level
 	 nested-vm
 	 ground-vm)
 
@@ -31,117 +35,40 @@
 ;; A fresh unification variable, as identifier-syntax.
 (define-syntax ? (syntax-id-rules () (_ (wild))))
 
-(define-syntax endpoint
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~or (~seq #:subscriber (~bind [is-subscriber #'#t]))
-	       (~seq #:publisher (~bind [is-publisher #'#t])))
-	  topic-expr
-	  (~or (~seq #:participant (~bind [is-participant #'#t]))
-	       (~seq #:observer (~bind [is-observer #'#t]))
-	       (~seq #:everything (~bind [is-everything #'#t]))
-	       (~seq))
-	  (~or (~optional (~seq #:let-name name-binding)
-			  #:defaults ([name-binding #'n0])
-			  #:name "#:let-name binding for endpoint name")
-	       (~optional (~seq #:name pre-eid) #:name "#:name of endpoint")
-	       (~optional (~seq #:state state-pattern) #:name "#:state pattern")
-	       (~optional (~seq #:on-presence presence) #:name "#:on-presence handler")
-	       (~optional (~seq #:on-absence absence) #:name "#:on-absence handler")
-
-	       (~optional (~seq #:role role) #:name "#:role")
-	       (~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation")
-	       (~optional (~seq #:conversation conversation) #:name "#:conversation")
-	       (~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type")
-
-	       (~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason"))
-	  ...
-	  [message-pattern clause-body]
-	  ...)
-       (define-syntax-rule (build-handler event-pattern e-attr)
-	 (if (attribute e-attr)
-	     #`([event-pattern
-		 #,(if (attribute state-pattern)
-		       #`(match-lambda [state-pattern e-attr])
-		       #`(lambda (state) (core:transition state e-attr)))])
-	     #`([event-pattern (lambda (state) (core:transition state '()))])))
-       (define role-pattern
-	 (cond
-	  [(attribute role)
-	   (when (or (attribute orientation)
-		     (attribute conversation)
-		     (attribute interest))
-	     (raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx))
-	   #'role]
-	  [else
-	   #`(core:role #,(if (attribute orientation) #'orientation #'_)
-			#,(if (attribute conversation) #'conversation #'_)
-			#,(if (attribute interest) #'interest #'_))]))
-       #`(let ((name-binding #,(if (attribute pre-eid)
-				   #'pre-eid
-				   #'(gensym 'anonymous-endpoint))))
-	   (core:add-endpoint
-	    name-binding
-	    (core:role #,(cond
-			  [(attribute is-subscriber) #''subscriber]
-			  [(attribute is-publisher) #''publisher]
-			  [else (raise-syntax-error #f
-						    "Missing #:subscriber or #:publisher"
-						    stx)])
-		       topic-expr
-		       #,(cond
-			  [(attribute is-participant) #''participant]
-			  [(attribute is-observer) #''observer]
-			  [(attribute is-everything) #''everything]
-			  [else #''participant]))
-	    (match-lambda
-	     #,@(build-handler (core:presence-event #,role-pattern) presence)
-	     #,@(build-handler (core:absence-event #,role-pattern reason) absence)
-	     [(core:message-event #,role-pattern message)
-	      #,(if (attribute state-pattern)
-		    #`(match-lambda
-		       [(and state state-pattern)
-			(match message
-			  [message-pattern clause-body] ...
-			  [_ (core:transition state '())])])
-		    #`(lambda (state)
-			(core:transition state
-					 (match message
-					   [message-pattern clause-body] ...
-					   [_ '()]))))]
-	     [_
-	      (lambda (state) (core:transition state '()))])))])))
-
 (define-syntax spawn
   (lambda (stx)
     (syntax-parse stx
-      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
-	       (~optional (~seq #:debug-name debug-name)
+	  exp)
-			  #:defaults ([debug-name #'#f])
+       #`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
-			  #:name "#:debug-name")) ...
+		     #f
-	  (~or (~seq #:parent parent-state-pattern (~and (~not #:child) parent-k-exp))
+		     #f)])))
-	       (~seq #:parent (~and (~not #:child) parent-k-exp))
+
-	       (~seq))
+(define-syntax spawn/continue
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
+	  #:parent parent-state-pattern parent-k-exp
 	  #:child exp)
-       #`(core:spawn (core:process-spec (lambda (pid)
+       #`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
-					  (lambda (k) (k exp))))
+		     (lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
-		     #,(if (attribute parent-k-exp)
+		     #f)])))
-			   (if (attribute parent-state-pattern)
+
-			       #`(lambda (pid)
+(define (name-process n p)
-				   (match-lambda [parent-state-pattern parent-k-exp]))
+  (match p
-			       #`(lambda (pid)
+    [(core:spawn spec parent-k _)
-				   (lambda (state)
+     (core:spawn spec parent-k n)]))
-				     (core:transition state parent-k-exp))))
-			   #'#f)
-		     debug-name)])))
 
 (define-syntax yield
   (lambda (stx)
     (syntax-case stx ()
-      [(_ #:state state-pattern exp)
+      [(_ state-pattern exp)
-       #'(core:yield (match-lambda [state-pattern exp]))]
+       #'(core:yield (match-lambda [state-pattern exp]))])))
-      [(_ exp)
+
-       #'(core:yield (lambda (state) (core:transition state exp)))])))
+(define (at-meta-level . preactions)
+  (match preactions
+    [(cons preaction '()) (core:at-meta-level preaction)]
+    [_ (map core:at-meta-level preactions)]))
 
 (define-syntax nested-vm
   (lambda (stx)
@@ -179,3 +106,8 @@
 	  (core:process-spec (lambda (boot-pid)
 			       (lambda (k) (k (core:transition initial-state
 							       (list exp ...)))))))])))
+
+;;; Local Variables:
+;;; eval: (put 'name-process 'scheme-indent-function 1)
+;;; eval: (put 'yield 'scheme-indent-function 1)
+;;; End:

marketplace/sugar-values.rkt

@@ -4,7 +4,6 @@
 (require (prefix-in core: "main.rkt"))
 
 (provide transition
-	 at-meta-level
 	 delete-endpoint
 	 send-message
 	 send-feedback
@@ -16,14 +15,6 @@
 (define (transition state . actions)
   ((inst core:transition State) state actions))
 
-(: at-meta-level : (All (State)
-			(core:PreAction State) *
-			-> (core:ActionTree State)))
-(define (at-meta-level . preactions)
-  (match preactions
-    [(cons preaction '()) (core:at-meta-level preaction)]
-    [_ ((inst map (core:Action State) (core:PreAction State)) core:at-meta-level preactions)]))
-
 (define (delete-endpoint #{id : Any}
 			 [#{reason : Any} #f])
   (core:delete-endpoint (cast id core:PreEID) (cast reason core:Reason)))

marketplace/support/dsl-typed.rkt

@@ -0,0 +1,26 @@
+#lang typed/racket/base
+
+(require (for-syntax typed/racket/base))
+(provide define&provide-dsl-helper-syntaxes)
+(provide literal-identifier=?)
+
+(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
+  (begin (provide identifier ...)
+	 (define-syntax identifier
+	   (lambda (stx)
+	     (raise-syntax-error #f
+				 (format "Illegal use of ~a outside ~a"
+					 'identifier
+					 context)
+				 stx)))
+	 ...))
+
+;; Typed racket wraps literal identifiers during provide. Here we dig
+;; through the renamings to see if they're the same thing. Gross!
+;; Fragile?
+(: literal-identifier=? : Syntax Identifier -> Boolean)
+(define (literal-identifier=? actual expected)
+  (and (identifier? actual)
+       (identifier-binding actual)
+       (eq? (syntax-local-value actual)
+	    (syntax-local-value expected))))

marketplace/support/dsl-untyped.rkt

@@ -0,0 +1,15 @@
+#lang racket/base
+
+(require (for-syntax racket/base))
+(provide define&provide-dsl-helper-syntaxes)
+
+(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
+  (begin (provide identifier ...)
+	 (define-syntax identifier
+	   (lambda (stx)
+	     (raise-syntax-error #f
+				 (format "Illegal use of ~a outside ~a"
+					 'identifier
+					 context)
+				 stx)))
+	 ...))

marketplace/support/spy.rkt

@@ -6,27 +6,27 @@
 
 (: generic-spy : (All (ParentState) Any -> (Spawn ParentState)))
 (define (generic-spy label)
-  (spawn: #:debug-name `(generic-spy ,label)
+  (name-process `(generic-spy ,label)
-	  #:parent : ParentState
+    (spawn: #:parent : ParentState
-	  #:child : Void
+	    #:child : Void
-	  (transition: (void) : Void
+	    (transition: (void) : Void
-	    (endpoint: : Void
+	      (observe-publishers: Void (wild)
-		       #:subscriber (wild) #:observer
+		(match-orientation orientation
-		       #:peer-orientation orientation
+		  (match-conversation topic
-		       #:conversation topic
+		    (match-interest-type interest
-		       #:peer-interest-type interest
+		      (match-reason reason
-		       #:reason reason
+			(on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
-		       #:on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
 					    (newline)
 					    (flush-output)
-					    '())
+					    '()))
-		       #:on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
+			(on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
 					   (newline)
 					   (display reason)
 					   (newline)
 					   (flush-output)
-					   '())
+					   '()))
-		       [p (begin (write `(,label MSG ,p))
+			(on-message
-				 (newline)
+			 [p (begin (write `(,label MSG ,p))
-				 (flush-output)
+				   (newline)
-				 '())]))))
+				   (flush-output)
+				   '())]))))))))))