Point example URLs in README to typeless branch

In the README file, the URLs to code examples are currently pointing to
files in a non-existing master branch. This change updates them to point
to files in an existing branch.

.gitignore

@@ -1,2 +1,3 @@
 compiled/
+doc/
 scratch/

Makefile

@@ -1,12 +1,10 @@
-COLLECTIONS=marketplace
-
 all: setup
 
 clean:
 	find . -name compiled -type d | xargs rm -rf
 
 setup:
-	raco setup $(COLLECTIONS)
+	raco setup $$(basename $$(pwd))
 
 link:
 	raco pkg install --link $$(pwd)

README.md

@@ -26,49 +26,44 @@ A (draft) manual for Marketplace is available
 
 ## The code
 
-This repository contains a [Racket](http://racket-lang.org/) package
-containing a single
-[collection](http://docs.racket-lang.org/reference/collects.html),
+This repository contains a [Racket](http://racket-lang.org/) package,
 `marketplace`, which includes
 
- - the implementation of the `#lang marketplace` language, in
-   [`marketplace/`](https://github.com/tonyg/marketplace/tree/master/marketplace/).
+ - the implementation of the `#lang marketplace` language, in the
+   [top directory](https://github.com/tonyg/marketplace/tree/typeless/).
 
  - a TCP echo server example, in
-   [`marketplace/examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/echo-paper.rkt).
+   [`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
 
  - a TCP chat server example, in
-   [`marketplace/examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/chat-paper.rkt).
+   [`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
 
  - Haskell, Erlang and Python implementations of the chat server for comparison, in
-   [`marketplace/examples/chat.hs`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/chat.hs),
-   [`chat.erl`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/chat.erl),
+   [`examples/chat.hs`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.hs),
+   [`chat.erl`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.erl),
    and
-   [`chat.py`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/chat.py)
+   [`chat.py`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.py)
    respectively.
 
 ## Compiling and running the code
 
-You will need the latest **prerelease** version of Racket. Any version
-newer than or equal to Racket 5.3.4.11 should work. Nightly-build
-installers for Racket can be downloaded
-[here](http://pre.racket-lang.org/installers/).
+You will need Racket version 6.1.x or later.
 
 Once you have Racket installed, run
 
+    raco pkg install marketplace
+
+to install the package from the Racket package repository, or
+
     raco pkg install --link `pwd`
 
-from the root directory of the Git checkout to install the package in
-your Racket system. (Alternatively, `make link` does the same thing.)
+from the root directory of the Git checkout to install the package
+from a local snapshot. (Alternatively, `make link` does the same thing.)
 This will make `#lang marketplace` available to programs.
 
-It will take several minutes to compile the code. On my Macbook Air,
-it takes around 10 minutes; on my ridiculously fast desktop machine,
-it still takes around 2 minutes.
-
 At this point, you may load and run any of the example `*.rkt` files
 in the
-[`marketplace/examples/`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/)
+[`examples/`](https://github.com/tonyg/marketplace/tree/typeless/examples/)
 directory.
 
 Note that both the echo server and chat server examples do not print
@@ -81,4 +76,4 @@ so you cannot run both simultaneously.
 
 ## Copyright
 
-Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013.
+Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014.

action-add-endpoint.rkt

@@ -1,16 +1,15 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "process.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide do-add-endpoint)
 
-(: do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
-			  -> (values (Option (process State)) vm)))
+;; do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
+;; 			  -> (values (Option (process State)) vm))
 (define (do-add-endpoint pre-eid role h p state)
   (define new-eid (eid (process-pid p) pre-eid))
   (define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f)))
@@ -35,7 +34,7 @@
 						      state)))
 	(values p state))))
 
-(: install-endpoint : (All (State) (process State) (endpoint State) -> (process State)))
+;; install-endpoint : (All (State) (process State) (endpoint State) -> (process State))
 (define (install-endpoint p ep)
   (define pre-eid (eid-pre-eid (endpoint-id ep)))
   (struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)]))

action-delete-endpoint.rkt

@@ -1,46 +1,44 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "process.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
+(require "quasiqueue.rkt")
 
 (provide do-delete-endpoint
 	 delete-all-endpoints)
 
-(: do-delete-endpoint : (All (State) PreEID Reason (process State) vm
-			     -> (values (process State) vm)))
+;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm
+;; 			     -> (values (process State) vm))
 (define (do-delete-endpoint pre-eid reason p state)
   (cond
    [(hash-has-key? (process-endpoints p) pre-eid)
     (define old-endpoint (hash-ref (process-endpoints p) pre-eid))
     (let-values (((p state) (notify-route-change-vm (remove-endpoint p old-endpoint)
 						    old-endpoint
-						    (lambda: ([t : Role]) (absence-event t reason))
+						    (lambda (t) (absence-event t reason))
 						    state)))
       (values p state))]
    [else
     (values p state)]))
 
-(: remove-endpoint : (All (State) (process State) (endpoint State) -> (process State)))
+;; remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))
 (define (remove-endpoint p ep)
   (define pre-eid (eid-pre-eid (endpoint-id ep)))
   (struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)]))
 
-(: delete-all-endpoints : (All (State) Reason (process State) vm
-			       -> (values (process State) vm (QuasiQueue (Action vm)))))
+;; delete-all-endpoints : (All (State) Reason (process State) vm
+;; 			       -> (values (process State) vm (QuasiQueue (Action vm))))
 (define (delete-all-endpoints reason p state)
   (let-values (((p state)
-		(for/fold: : (values (process State) vm)
-		    ([p p] [state state])
+		(for/fold ([p p] [state state])
 		    ([pre-eid (in-hash-keys (process-endpoints p))])
 		  (do-delete-endpoint pre-eid reason p state))))
     (values p
 	    state
 	    (list->quasiqueue
-	     (map (lambda (#{pre-eid : PreEID})
-		    (delete-endpoint (cast (eid (process-pid p) pre-eid) PreEID)
-				     reason))
+	     (map (lambda (pre-eid)
+		    (delete-endpoint (eid (process-pid p) pre-eid) reason))
 		  (hash-keys (process-meta-endpoints p)))))))

action-quit.rkt

@@ -1,31 +1,30 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log-typed.rkt")
+(require "log.rkt")
 (require "process.rkt")
 (require "action-delete-endpoint.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
-
-(require/typed web-server/private/util
-	       [exn->string (exn -> String)])
+(require "quasiqueue.rkt")
 
 (provide do-quit)
 
-(: do-quit : (All (State) PID Reason (process State) vm
-		  -> (values (Option (process State)) vm (QuasiQueue (Action vm)))))
+;; do-quit : (All (State) PID Reason (process State) vm
+;; 		  -> (values (Option (process State)) vm (QuasiQueue (Action vm))))
 (define (do-quit killed-pid reason p state)
 
-  (: log-quit : (All (KilledState) (process KilledState) -> Void))
+  ;; log-quit : (All (KilledState) (process KilledState) -> Void)
   (define (log-quit p)
     (marketplace-log (if reason 'warning 'info)
 		     "PID ~v (~a) quits with reason: ~a"
 		     killed-pid
 		     (process-debug-name p)
 		     (if (exn? reason)
-			 (exn->string reason)
+                         (parameterize ([current-error-port (open-output-string)])
+                           ((error-display-handler) (exn-message reason) reason)
+                           (get-output-string (current-error-port)))
 			 (format "~v" reason))))
 
   (if (equal? killed-pid (process-pid p))
@@ -36,9 +35,7 @@
 	(if (not maybe-killed-wp)
 	    (values p state (empty-quasiqueue))
 	    (apply values
-		   (unwrap-process KilledState
-		       (List (Option (process State)) vm (QuasiQueue (Action vm)))
-		       (killed-p maybe-killed-wp)
+		   (let ((killed-p maybe-killed-wp))
 		     (log-quit killed-p)
 		     (let-values (((killed-p state meta-actions)
 				   (delete-all-endpoints reason killed-p state)))

action-send-message.rkt

@@ -1,24 +1,22 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "process.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide do-send-message)
 
-(: do-send-message : (All (State) Orientation Message (process State) vm ->
-			  (Values (Option (process State)) vm)))
+;; do-send-message : (All (State) Orientation Message (process State) vm ->
+;; 			  (Values (Option (process State)) vm))
 (define (do-send-message orientation body sender-p state)
   (define message-role (role orientation body 'participant))
 
-  (: send-to-process : (All (State) (process State) -> (process State)))
+  ;; send-to-process : (All (State) (process State) -> (process State))
   (define (send-to-process p)
     (define endpoints (process-endpoints p))
-    (for/fold: : (process State) ([p p])
-	([eid (in-hash-keys endpoints)])
+    (for/fold ([p p]) ([eid (in-hash-keys endpoints)])
       (define e (hash-ref endpoints eid))
       (cond
        [(role-intersection message-role (endpoint-role e))

action-spawn.rkt

@@ -1,46 +1,44 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log-typed.rkt")
+(require "log.rkt")
 (require "process.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide do-spawn)
 
-(: do-spawn : (All (OldState)
-		   process-spec
-		   (Option (PID -> (InterruptK OldState)))
-		   (process OldState)
-		   Any
-		   vm
-		   -> (Values (Option (process OldState)) vm)))
+;; do-spawn : (All (OldState)
+;; 		   process-spec
+;; 		   (Option (PID -> (InterruptK OldState)))
+;; 		   (process OldState)
+;; 		   Any
+;; 		   vm
+;; 		   -> (Values (Option (process OldState)) vm))
 (define (do-spawn spec parent-k p debug-name state)
   (define new-pid (vm-next-process-id state))
   (marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name)
-  (: new-cotransition : CoTransition)
+  ;; new-cotransition : CoTransition
   (define new-cotransition
     (send-to-user* debug-name new-pid (e) (co-quit e)
       ((process-spec-boot spec) new-pid)))
-  (: co-quit : Reason -> CoTransition)
+  ;; co-quit : Reason -> CoTransition
   (define ((co-quit e) k)
-    ((inst k False) (transition #f (quit #f e))))
-  (: transition-accepter : (All (NewState) (Transition NewState) -> Process))
+    (k (transition #f (quit #f e))))
+  ;; transition-accepter : (All (NewState) (Transition NewState) -> Process)
   (define (transition-accepter t)
     (match-define (transition initial-state initial-actions) t)
-    (mkProcess ((inst process NewState)
-		debug-name
-		new-pid
-		initial-state
-		'()
-		#hash()
-		#hash()
-		(action-tree->quasiqueue initial-actions))))
+    (process debug-name
+	     new-pid
+	     initial-state
+	     '()
+	     #hash()
+	     #hash()
+	     (action-tree->quasiqueue initial-actions)))
   (let ((new-process
 	 (send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e)))
-	   ((inst new-cotransition Process) transition-accepter))))
+	   (new-cotransition transition-accepter))))
     (values (if parent-k
 		(run-ready p (send-to-user p (e) (quit-interruptk e)
 			       (parent-k new-pid)))

actions.rkt

@@ -1,10 +1,10 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log-typed.rkt")
+(require "log.rkt")
 (require "process.rkt")
 (require "action-add-endpoint.rkt")
 (require "action-delete-endpoint.rkt")
@@ -12,18 +12,17 @@
 (require "action-spawn.rkt")
 (require "action-quit.rkt")
 (require "list-utils.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
+(require "quasiqueue.rkt")
 
 (provide run-vm)
 
-(: dump-state : vm -> Any)
+;; dump-state : vm -> Any
 (define (dump-state state)
   `(vm (next-pid ,(vm-next-process-id state))
-       (processes ,@(for/fold: : Any
-		        ([acc '()])
+       (processes ,@(for/fold ([acc '()])
 			([pid (in-hash-keys (vm-processes state))])
 		      (cons (list pid (let ((wp (hash-ref (vm-processes state) pid)))
-					(unwrap-process State Any (p wp)
+					(let ((p wp))
 					  (list (match (process-state p)
 						  [(? vm? v) (dump-state v)]
 						  [v v])
@@ -32,16 +31,16 @@
 						(process-meta-endpoints p)
 						(process-pending-actions p))))) acc)))))
 
-(: run-vm : vm -> (Transition vm))
+;; run-vm : vm -> (Transition vm)
 (define (run-vm state)
   ;; for each pid,
   ;; extract the corresponding process.
   ;; run through its work items, collecting external actions.
   ;; put the process back.
   ;; return the new state and the external actions
-  (let next-process ((remaining-pids ((inst hash-keys PID Process) (vm-processes state)))
+  (let next-process ((remaining-pids (hash-keys (vm-processes state)))
 		     (state state)
-		     (external-actions ((inst empty-quasiqueue (Action vm)))))
+		     (external-actions (empty-quasiqueue)))
     (match remaining-pids
       ['()
        (let ((state (collect-dead-processes state))
@@ -54,7 +53,7 @@
        (let-values (((state wp) (extract-process state pid)))
 	 (if (not wp)
 	     (next-process remaining-pids state external-actions)
-	     (unwrap-process State (transition vm) (p wp)
+	     (let ((p wp))
 	       (let next-action
 		   ([remaining-actions (quasiqueue->list (process-pending-actions p))]
 		    [p (reset-pending-actions p)]
@@ -63,7 +62,7 @@
 		 (match remaining-actions
 		   ['()
 		    (next-process remaining-pids
-				  (inject-process state (mkProcess p))
+				  (inject-process state p)
 				  external-actions)]
 		   [(cons action remaining-actions)
 		    (marketplace-log 'debug
@@ -84,20 +83,19 @@
 					(quasiqueue-append external-actions
 							   new-external-actions))))])))))])))
 
-(: collect-dead-processes : vm -> vm)
+;; collect-dead-processes : vm -> vm
 (define (collect-dead-processes state)
-  (: process-alive? : (All (State) (process State) -> Boolean))
+  ;; process-alive? : (All (State) (process State) -> Boolean)
   (define (process-alive? p)
     (or (not (null? (process-spawn-ks p)))
 	(positive? (hash-count (process-endpoints p)))
 	(positive? (hash-count (process-meta-endpoints p)))
 	(not (quasiqueue-empty? (process-pending-actions p)))))
   (struct-copy vm state
-    [processes (for/fold: : (HashTable PID Process)
-		   ([processes (ann #hash() (HashTable PID Process))])
+    [processes (for/fold ([processes #hash()])
 		   ([pid (in-hash-keys (vm-processes state))])
 		 (define wp (hash-ref (vm-processes state) pid))
-		 (unwrap-process State (HashTable PID Process) (p wp)
+		 (let ((p wp))
 		   (if (process-alive? p)
 		       (hash-set processes pid wp)
 		       (begin (marketplace-log 'info
@@ -106,20 +104,21 @@
 					       (process-debug-name p))
 			      processes))))]))
 
-(: vm-idle? : vm -> Boolean)
+;; vm-idle? : vm -> Boolean
+;; TODO: simplify
 (define (vm-idle? state)
-  (andmap (lambda (#{pid : PID})
+  (andmap (lambda (pid)
 	    (define wp (hash-ref (vm-processes state) pid))
-	    (unwrap-process State Boolean (p wp)
+	    (let ((p wp))
 	      (quasiqueue-empty? (process-pending-actions p))))
 	  (hash-keys (vm-processes state))))
 
-(: perform-action : (All (State) (Action State) (process State) vm
-			 -> (Values (Option (process State)) vm (QuasiQueue (Action vm)))))
+;; perform-action : (All (State) (Action State) (process State) vm
+;; 			 -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))
 (define (perform-action action p state)
   (match action
     [(at-meta-level preaction)
-     ((inst transform-meta-action State) preaction p state)]
+     (transform-meta-action preaction p state)]
     [(yield k)
      (let ((p (run-ready p k)))
        (values p state (empty-quasiqueue)))]
@@ -140,39 +139,39 @@
 	     new-state
 	     (empty-quasiqueue))]))
 
-(: wrap-trapk : eid -> (Handler vm))
+;; wrap-trapk : eid -> (Handler vm)
 (define (((wrap-trapk target-eid) event) state)
   (match-define (eid pid pre-eid) target-eid)
   (run-vm
    (let-values (((state wp) (extract-process state pid)))
      (if (not wp)
 	 state
-	 (unwrap-process State vm (p wp)
+	 (let ((p wp))
 	   (define ep (hash-ref (process-meta-endpoints p) pre-eid always-false))
 	   (if (not ep)
-	       (inject-process state (mkProcess p))
+	       (inject-process state p)
 	       (let ((p (run-ready p (send-to-user p (e) (quit-interruptk e)
 				       ((endpoint-handler ep) event)))))
-		 (inject-process state (mkProcess p)))))))))
+		 (inject-process state p))))))))
 
-(: dispatch-spawn-k : PID Integer -> (TrapK PID vm))
+;; dispatch-spawn-k : PID Integer -> (TrapK PID vm)
 (define (((dispatch-spawn-k pid spawn-k-id) new-pid) state)
   (run-vm
    (let-values (((state wp) (extract-process state pid)))
      (if (not wp)
 	 state
-	 (unwrap-process State vm (p wp)
+	 (let ((p wp))
 	   (match (assoc spawn-k-id (process-spawn-ks p))
 	     [#f
-	      (inject-process state (mkProcess p))]
+	      (inject-process state p)]
 	     [(and entry (cons _ k))
 	      (define interruptk (send-to-user p (e) (quit-interruptk e)
 				   (k new-pid)))
 	      (define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))]))
-	      (inject-process state (mkProcess (run-ready p1 interruptk)))]))))))
+	      (inject-process state (run-ready p1 interruptk))]))))))
 
-(: transform-meta-action : (All (State) (PreAction State) (process State) vm ->
-				(Values (Option (process State)) vm (QuasiQueue (Action vm)))))
+;; transform-meta-action : (All (State) (PreAction State) (process State) vm ->
+;; 				(Values (Option (process State)) vm (QuasiQueue (Action vm))))
 (define (transform-meta-action pa p state)
   (match pa
     [(add-endpoint pre-eid role unwrapped-handler)
@@ -180,13 +179,12 @@
      (values (struct-copy process p
 			  [meta-endpoints (hash-set (process-meta-endpoints p)
 						    pre-eid
-						    ((inst endpoint State)
-						     new-eid
-						     role
-						     unwrapped-handler))])
+						    (endpoint new-eid
+							      role
+							      unwrapped-handler))])
 	     state
 	     (quasiqueue
-	      (add-endpoint (cast new-eid PreEID)
+	      (add-endpoint new-eid
 			    role
 			    (wrap-trapk new-eid))))]
     [(delete-endpoint pre-eid reason)
@@ -194,7 +192,7 @@
      (values (struct-copy process p
 			  [meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)])
 	     state
-	     (quasiqueue (delete-endpoint (cast old-eid PreEID) reason)))]
+	     (quasiqueue (delete-endpoint old-eid reason)))]
     [(send-message body orientation)
      (values p
 	     state
@@ -202,15 +200,14 @@
     [(spawn spec k debug-name)
      (define pid (process-pid p))
      (if k
-	 (let ((spawn-k-id (+ 1 (list-max (map (inst car Integer (TrapK PID State))
-					       (process-spawn-ks p))))))
+	 (let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p))))))
 	   (values (struct-copy process p
 				[spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))])
 		   state
 		   (quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name))))
 	 (values p
 		 state
-		 (quasiqueue ((inst spawn vm) spec #f debug-name))))]
+		 (quasiqueue (spawn spec #f debug-name))))]
     [(quit maybe-pid reason)
      (values p
 	     state

drivers/event-relay.rkt

@@ -0,0 +1,27 @@
+#lang racket/base
+;; Ground-event relay.
+
+(provide event-relay)
+(require "../sugar.rkt")
+
+;; event-relay : (All (ParentState) Symbol -> (Spawn ParentState))
+(define (event-relay self-id)
+  (name-process `(event-relay ,self-id)
+    (spawn (transition/no-state
+	     (observe-subscribers (cons ? ?)
+	       (match-conversation (cons (? evt? e) _)
+		 (on-presence (begin
+				(printf "SUBSCRIBED ~v~n" e)
+				(flush-output)
+				(at-meta-level
+				 (name-endpoint `(event-relay ,self-id ,e)
+				   (subscriber (cons e ?)
+				     (on-message
+				      [msg (begin (printf "FIRED ~v -> ~v~n" e msg)
+						  (flush-output)
+						  (send-message msg))]))))))
+		 (on-absence (begin
+			       (printf "UNSUBSCRIBED ~v~n" e)
+			       (flush-output)
+			       (at-meta-level
+				(delete-endpoint `(event-relay ,self-id ,e)))))))))))

drivers/tcp-bare-with-ground.rkt

@@ -0,0 +1,179 @@
+#lang racket/base
+;; TCP drivers, ported from os2.rkt directly, with flow-control and line discipline removed
+
+(require racket/set)
+(require racket/match)
+(require (prefix-in tcp: racket/tcp))
+(require racket/port)
+(require "../sugar.rkt")
+(require "../support/dump-bytes.rkt")
+(require "../unify.rkt")
+
+(provide (struct-out tcp-address)
+	 (struct-out tcp-handle)
+	 (struct-out tcp-listener)
+	 (struct-out tcp-channel)
+	 tcp
+	 tcp-driver)
+
+(struct tcp-address (host port) #:prefab)
+(struct tcp-handle (id) #:prefab)
+(struct tcp-listener (port) #:prefab)
+
+(struct tcp-channel (source destination subpacket) #:prefab)
+
+(define any-remote (tcp-address (wild) (wild)))
+(define any-handle (tcp-handle (wild)))
+(define any-listener (tcp-listener (wild)))
+
+(define (tcp-driver)
+  (name-process 'tcp-driver
+    (spawn
+     (transition (set)
+       (observe-publishers/everything (tcp-channel any-listener any-remote (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
+       (observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))
+       (observe-publishers (tcp-channel any-handle any-remote (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence
+	      (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
+       (observe-subscribers (tcp-channel any-remote any-handle (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (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 orientation c active-handles remote-should-be-ground driver-fun)
+  (match (list orientation c)
+    [(or (list 'publisher (tcp-channel local-addr remote-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))
+	 (name-process (cons local-addr remote-addr)
+	   (spawn (driver-fun local-addr remote-addr))))])]))
+
+;; Orientation Topic Set<HandleMapping> -> Transition
+(define (maybe-forget-socket orientation c active-handles)
+  (match (list orientation c)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
+     (cond
+      [(ground? remote-addr) (transition active-handles)]
+      [(not (ground? local-addr)) (transition active-handles)]
+      [else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
+
+;; TcpAddress TcpAddress -> Transition
+(define (tcp-listener-manager local-addr dummy-remote-addr)
+  (match-define (tcp-listener port) local-addr)
+  (define listener (tcp:tcp-listen port 4 #t))
+
+  (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 (list orientation c)
+      [(or (list 'publisher (tcp-channel (== local-addr) remote-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)
+	       (name-process (list 'tcp-listener-closer local-addr)
+		 (spawn (begin (tcp:tcp-close listener)
+			       (transition 'dummy (quit))))))))]))
+
+  (transition 'listener-is-running
+    (observe-publishers/everything (tcp-channel local-addr any-remote (wild))
+      (match-state state
+	(match-conversation c
+	  (on-absence (handle-absence 'publisher c state)))))
+    (observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
+      (match-state state
+	(match-conversation c
+	  (on-absence (handle-absence 'subscriber c state)))))
+    (subscriber (cons (tcp:tcp-accept-evt listener) (wild))
+      (on-message
+       [(cons _ (list cin cout))
+	(let-values (((local-hostname local-port remote-hostname remote-port)
+		      (tcp:tcp-addresses cin #t)))
+	  (define remote-addr (tcp-address remote-hostname remote-port))
+	  (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)
+  (match-define (tcp-address remote-hostname remote-port) remote-addr)
+  (define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
+  (tcp-connection-manager* local-addr remote-addr cin cout))
+
+(define (read-bytes-avail-evt len input-port)
+  (guard-evt
+   (lambda ()
+     (let ([bstr (make-bytes len)])
+       (wrap-evt
+        (read-bytes-avail!-evt bstr input-port)
+        (lambda (v)
+          (if (number? v)
+              (if (= v len) bstr (subbytes bstr 0 v))
+              v)))))))
+
+;; TcpAddress TcpAddress InputPort OutputPort -> Transition
+;;
+;; Our process state here is a Maybe<TcpConnectionState>, representing
+;; a shutting-down state if #f.
+(define (tcp-connection-manager* local-addr remote-addr cin cout)
+  (define (close-transition is-open send-eof?)
+    (transition #f
+      (when is-open
+	(list (when send-eof?
+		(send-message (tcp-channel remote-addr local-addr eof)))
+	      (name-process (list 'tcp-connection-closer local-addr remote-addr)
+		(spawn (begin (tcp:tcp-abandon-port cin)
+			      (tcp:tcp-abandon-port cout)
+			      (transition/no-state (quit)))))))
+      (quit)))
+
+  (transition #t ;; open
+    (subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
+      (match-state is-open
+	(on-message
+	 [(cons _ (? eof-object?)) (close-transition is-open #t)]
+	 [(cons _ (? bytes? bs)) (transition is-open
+				   (send-message (tcp-channel remote-addr local-addr bs)))])))
+    (subscriber (cons (eof-evt cin) (wild))
+      (match-state is-open
+	(on-message [(cons (? evt?) _) (close-transition is-open #t)])))
+    (subscriber (tcp-channel local-addr remote-addr (wild))
+      (match-state is-open
+	(on-absence (close-transition is-open #f))
+	(on-message
+	 [(tcp-channel (== local-addr) (== remote-addr) subpacket)
+	  (match subpacket
+	    [(? eof-object?) (close-transition is-open #f)]
+	    [(? string? s) (begin (write-string s cout)
+				  (flush-output cout)
+				  (transition is-open))]
+	    [(? bytes? bs) (begin (write-bytes bs cout)
+				  (flush-output cout)
+				  (transition is-open))])])))
+    (publisher (tcp-channel remote-addr local-addr (wild))
+      (match-state is-open
+	(on-absence (close-transition is-open #f))))))

drivers/tcp-bare.rkt

@@ -0,0 +1,157 @@
+#lang racket/base
+;; TCP driver, with flow-control and line discipline removed, sans reliance on (ground?)
+
+(require racket/set)
+(require racket/match)
+(require (prefix-in tcp: racket/tcp))
+(require racket/port)
+(require "../sugar.rkt")
+(require "../support/dump-bytes.rkt")
+
+(provide (struct-out tcp-address)
+	 (struct-out tcp-handle)
+	 (struct-out tcp-listener)
+	 (struct-out tcp-channel)
+	 tcp
+	 tcp-driver)
+
+(struct tcp-address (host port) #:prefab)
+(struct tcp-handle (id) #:prefab)
+(struct tcp-listener (port) #:prefab)
+
+(struct tcp-channel (source destination subpacket) #:prefab)
+
+(define any-remote (tcp-address (wild) (wild)))
+(define any-handle (tcp-handle (wild)))
+(define any-listener (tcp-listener (wild)))
+
+(define (tcp-driver)
+  (name-process 'tcp-driver
+    (spawn
+     (transition (set)
+       (observe-publishers/everything (tcp-channel any-listener any-remote (wild))
+	 (match-interest-type 'observer
+	   (match-state active-handles
+	     (match-conversation (tcp-channel L _ _)
+	       (on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
+	       (on-absence (maybe-forget-socket 'incoming L active-handles))))))
+       (observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
+	 (match-interest-type 'observer
+	   (match-state active-handles
+	     (match-conversation (tcp-channel _ L _)
+	       (on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
+	       (on-absence (maybe-forget-socket 'incoming L active-handles))))))
+       (observe-publishers (tcp-channel any-handle any-remote (wild))
+	 (match-state active-handles
+	   (match-conversation (tcp-channel L R _)
+	     (on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
+	     (on-absence (maybe-forget-socket R L active-handles)))))
+       (observe-subscribers (tcp-channel any-remote any-handle (wild))
+	 (match-state active-handles
+	   (match-conversation (tcp-channel R L _)
+	     (on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
+	     (on-absence (maybe-forget-socket R L active-handles)))))))))
+
+(define tcp (tcp-driver)) ;; pre-instantiated!
+
+(define (maybe-spawn-socket R L active-handles driver-fun)
+  (define name (cons L R))
+  (if (set-member? active-handles name)
+      (transition active-handles)
+      (transition (set-add active-handles name)
+	(name-process name (spawn (driver-fun L R))))))
+
+(define (maybe-forget-socket R L active-handles)
+  (define name (cons L R))
+  (transition (set-remove active-handles name)))
+
+;; TcpAddress 'incoming -> Transition
+(define (tcp-listener-manager local-addr dummy-incoming-marker)
+  (match-define (tcp-listener port) local-addr)
+  (define listener (tcp:tcp-listen port 4 #t))
+
+  (define (handle-absence)
+    ;; 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
+    (transition 'listener-is-closed
+      (name-process (list 'tcp-listener-closer local-addr)
+	(spawn (begin (tcp:tcp-close listener)
+		      (transition 'dummy (quit)))))
+      (quit)))
+
+  (transition 'listener-is-running
+    (observe-publishers/everything (tcp-channel local-addr any-remote (wild))
+      (match-interest-type 'observer
+	(match-state 'listener-is-running
+	  (on-absence (handle-absence)))))
+    (observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
+      (match-interest-type 'observer
+	(match-state 'listener-is-running
+	  (on-absence (handle-absence)))))
+    (subscriber (cons (tcp:tcp-accept-evt listener) (wild))
+      (on-message
+       [(cons _ (list cin cout))
+	(let-values (((local-hostname local-port remote-hostname remote-port)
+		      (tcp:tcp-addresses cin #t)))
+	  (define remote-addr (tcp-address remote-hostname remote-port))
+	  (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)
+  (match-define (tcp-address remote-hostname remote-port) remote-addr)
+  (define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
+  (tcp-connection-manager* local-addr remote-addr cin cout))
+
+(define (read-bytes-avail-evt len input-port)
+  (guard-evt
+   (lambda ()
+     (let ([bstr (make-bytes len)])
+       (wrap-evt
+        (read-bytes-avail!-evt bstr input-port)
+        (lambda (v)
+          (if (number? v)
+              (if (= v len) bstr (subbytes bstr 0 v))
+              v)))))))
+
+;; TcpAddress TcpAddress InputPort OutputPort -> Transition
+;;
+;; Our process state here is either 'open or 'closing.
+(define (tcp-connection-manager* local-addr remote-addr cin cout)
+  (define (close-transition send-eof?)
+    (transition 'closing
+      (when send-eof? (send-message (tcp-channel remote-addr local-addr eof)))
+      (name-process (list 'tcp-connection-closer local-addr remote-addr)
+	(spawn (begin (tcp:tcp-abandon-port cin)
+		      (tcp:tcp-abandon-port cout)
+		      (transition/no-state (quit)))))
+      (quit)))
+
+  (transition 'open
+    (subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
+      (match-state 'open
+	(on-message
+	 [(cons _ (? eof-object?)) (close-transition #t)]
+	 [(cons _ (? bytes? bs)) (transition 'open
+				   (send-message (tcp-channel remote-addr local-addr bs)))])))
+    (subscriber (cons (eof-evt cin) (wild))
+      (match-state 'open
+	(on-message [(cons (? evt?) _) (close-transition #t)])))
+    (subscriber (tcp-channel local-addr remote-addr (wild))
+      (match-state 'open
+	(on-absence (close-transition #f))
+	(on-message
+	 [(tcp-channel (== local-addr) (== remote-addr) subpacket)
+	  (match subpacket
+	    [(? eof-object?) (close-transition #f)]
+	    [(? string? s) (begin (write-string s cout)
+				  (flush-output cout)
+				  (transition 'open))]
+	    [(? bytes? bs) (begin (write-bytes bs cout)
+				  (flush-output cout)
+				  (transition 'open))])])))
+    (publisher (tcp-channel remote-addr local-addr (wild))
+      (match-state 'open
+	(on-absence (close-transition #f))))))

drivers/tcp.rkt

@@ -5,8 +5,9 @@
 (require racket/match)
 (require (prefix-in tcp: racket/tcp))
 (require racket/port)
-(require "../sugar-untyped.rkt")
+(require "../sugar.rkt")
 (require "../support/dump-bytes.rkt")
+(require "../unify.rkt")
 
 (provide (struct-out tcp-address)
 	 (struct-out tcp-handle)
@@ -81,93 +82,95 @@
 ;; Spawn
 ;; Process acting as a TCP socket factory.
 (define (tcp-driver)
-  (spawn #:debug-name 'tcp-driver
-	 #:child
-   (transition (set)
-     (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:publisher  (tcp-channel any-remote any-listener (wild)) #:everything
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:publisher  (tcp-channel any-remote any-handle (wild)) #:observer
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
-	       #:on-absence (maybe-forget-socket r active-handles)))))
+  (name-process 'tcp-driver
+    (spawn
+     (transition (set)
+       (observe-publishers/everything (tcp-channel any-listener any-remote (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
+       (observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
+	     (on-absence (maybe-forget-socket 'subscriber c active-handles)))))
+       (observe-publishers (tcp-channel any-handle any-remote (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (on-presence
+	      (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
+	     (on-absence (maybe-forget-socket 'publisher c active-handles)))))
+       (observe-subscribers (tcp-channel any-remote any-handle (wild))
+	 (match-state active-handles
+	   (match-conversation c
+	     (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
-(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
-  (match r
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
+(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
+  (match (list orientation c)
+    [(or (list 'publisher (tcp-channel local-addr remote-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)
-		#:child (driver-fun local-addr remote-addr)))])]))
+	 (name-process (cons local-addr remote-addr)
+	   (spawn (driver-fun local-addr remote-addr))))])]))
 
-;; Role Set<HandleMapping> -> Transition
-(define (maybe-forget-socket r active-handles)
-  (match r
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
+;; Orientation Topic Set<HandleMapping> -> Transition
+(define (maybe-forget-socket orientation c active-handles)
+  (match (list orientation c)
+    [(or (list 'publisher (tcp-channel local-addr remote-addr _))
+	 (list 'subscriber (tcp-channel remote-addr local-addr _)))
      (cond
       [(ground? remote-addr) (transition active-handles)]
       [(not (ground? local-addr)) (transition active-handles)]
-      [else (transition (set-remove active-handles local-addr))])]))
+      [else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
 
 ;; TcpAddress TcpAddress -> Transition
 (define (tcp-listener-manager local-addr dummy-remote-addr)
   (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
-      [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
-	   (role 'subscriber (tcp-channel remote-addr (== local-addr) _) _))
+    (match (list orientation c)
+      [(or (list 'publisher (tcp-channel (== local-addr) remote-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)
-		      #:child
-		      (begin (tcp:tcp-close listener)
-			     (transition 'dummy (quit)))))))]))
+	       (name-process (list 'tcp-listener-closer local-addr)
+		 (spawn (begin (tcp:tcp-close listener)
+			     (transition 'dummy (quit))))))))]))
 
   (transition 'listener-is-running
-    (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
-	      #:state state
-	      #:role r
-	      #:on-absence (handle-absence r state))
-    (endpoint #:publisher  (tcp-channel any-remote local-addr (wild)) #:everything
-	      #:state state
-	      #:role r
-	      #:on-absence (handle-absence r state))
-    (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
-	      [(cons _ (list cin cout))
-	       (let-values (((local-hostname local-port remote-hostname remote-port)
-			     (tcp:tcp-addresses cin #t)))
-		 (define remote-addr (tcp-address remote-hostname remote-port))
-		 (spawn #:debug-name (cons local-addr remote-addr)
-			#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
+    (observe-publishers/everything (tcp-channel local-addr any-remote (wild))
+      (match-state state
+	(match-conversation c
+	  (on-absence (handle-absence 'publisher c state)))))
+    (observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
+      (match-state state
+	(match-conversation c
+	  (on-absence (handle-absence 'subscriber c state)))))
+    (subscriber (cons (tcp:tcp-accept-evt listener) (wild))
+      (on-message
+       [(cons _ (list cin cout))
+	(let-values (((local-hostname local-port remote-hostname remote-port)
+		      (tcp:tcp-addresses cin #t)))
+	  (define remote-addr (tcp-address remote-hostname remote-port))
+	  (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 +188,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)
-		     #:child
-		     (begin (tcp:tcp-abandon-port cin)
-			    (tcp:tcp-abandon-port cout)
-			    (transition 'dummy (quit))))))
+	      (name-process (list 'tcp-connection-closer local-addr remote-addr)
+		(spawn(begin (tcp:tcp-abandon-port cin)
+			     (tcp:tcp-abandon-port cout)
+			     (transition 'dummy (quit)))))))
       (quit)))
   (define (adjust-credit state amount)
     (let ((new-credit (+ (tcp-connection-state-credit state) amount)))
@@ -198,56 +200,62 @@
 	(when (positive? new-credit)
 	  (case (tcp-connection-state-mode state)
 	    [(lines)
-	     (endpoint #:subscriber (cons (read-bytes-line-evt cin 'any) (wild))
-		       #:name 'inbound-relay
-		       #:state state
-	      [(cons _ (? eof-object?))
-	       (close-transition state #t)]
-	      [(cons _ (? bytes? bs))
-	       (sequence-actions (adjust-credit state -1)
-				 (send-message (tcp-channel remote-addr local-addr bs)))])]
+	     (name-endpoint 'inbound-relay
+	       (subscriber (cons (read-bytes-line-evt cin 'any) (wild))
+		 (match-state state
+		   (on-message
+		    [(cons _ (? eof-object?))
+		     (close-transition state #t)]
+		    [(cons _ (? bytes? 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 'inbound-relay
-		       #:state state
-	      [(cons _ (? eof-object?))
-	       (close-transition state #t)]
-	      [(cons _ (? bytes? bs))
-	       (let ((len (bytes-length bs)))
-		 (sequence-actions (adjust-credit state (- len))
-				   (send-message (tcp-channel remote-addr local-addr bs))))])])))))
+	     (name-endpoint 'inbound-relay
+	       (subscriber (cons (read-bytes-evt new-credit cin) (wild))
+		 (match-state state
+		   (on-message
+		    [(cons _ (? eof-object?))
+		     (close-transition state #t)]
+		    [(cons _ (? bytes? bs))
+		     (let ((len (bytes-length 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))
-	      #:state state
-     [(cons (? evt?) _)
-      (close-transition state #t)])
-    (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
-	      #:state state
-	      #:on-absence (close-transition state #f)
-     [(tcp-channel (== local-addr) (== remote-addr) subpacket)
-      (match subpacket
-	[(? eof-object?) (close-transition state #f)]
-	[(? bytes? bs)
-	 (define len (bytes-length bs))
-	 (write-bytes bs cout)
-	 (flush-output cout)
-	 (transition state (send-tcp-credit local-addr remote-addr len))]
-	[_
-	 (error 'tcp-connection-manager*
-		"Publisher on a channel isn't supposed to issue channel control messages")])])
-    (endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
-	      #:state state
-	      #:on-absence (close-transition state #f)
-     [(tcp-channel (== remote-addr) (== local-addr) subpacket)
-      (match subpacket
-	[(tcp-credit amount)
-	 (if state (adjust-credit state amount) (transition state))]
-	[(tcp-mode new-mode)
-	 ;; Also resets credit to zero.
-	 (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")])])))
+    (subscriber (cons (eof-evt cin) (wild))
+      (match-state state
+	(on-message
+	 [(cons (? evt?) _)
+	  (close-transition state #t)])))
+    (subscriber (tcp-channel local-addr remote-addr (wild))
+      (match-state state
+	(on-absence (close-transition state #f))
+	(on-message
+	 [(tcp-channel (== local-addr) (== remote-addr) subpacket)
+	  (match subpacket
+	    [(? eof-object?) (close-transition state #f)]
+	    [(? bytes? bs)
+	     (define len (bytes-length bs))
+	     (write-bytes bs cout)
+	     (flush-output cout)
+	     (transition state (send-tcp-credit local-addr remote-addr len))]
+	    [_
+	     (error 'tcp-connection-manager*
+		    "Publisher on a channel isn't supposed to issue channel control messages")])])))
+    (publisher (tcp-channel remote-addr local-addr (wild))
+      (match-state state
+	(on-absence (close-transition state #f))
+	(on-message
+	 [(tcp-channel (== remote-addr) (== local-addr) subpacket)
+	  (match subpacket
+	    [(tcp-credit amount)
+	     (if state (adjust-credit state amount) (transition state))]
+	    [(tcp-mode new-mode)
+	     ;; Also resets credit to zero.
+	     (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 +279,7 @@
        (write `(TCPOTHER ,other)) (newline)
        (void)]))
 
-  (spawn #:debug-name 'tcp-spy
-	 #:child
-	 (transition 'no-state
-	   (endpoint #:subscriber (wild) #:observer [m (display-message m)])
-	   (endpoint #:publisher (wild) #:observer [m (display-message m)]))))
+  (name-process 'tcp-spy
+    (spawn (transition 'no-state
+	     (observe-publishers (wild) (on-message [m (display-message m)]))
+	     (observe-subscribers (wild) (on-message [m (display-message m)]))))))

drivers/timer.rkt

@@ -0,0 +1,154 @@
+#lang racket/base
+;; Timer driver.
+
+;; Uses mutable state internally, but because the scope of the
+;; mutation is limited to each timer process alone, it's easy to show
+;; correct linear use of the various pointers.
+
+(require racket/set)
+(require racket/match)
+(require data/heap)
+(require "../sugar.rkt")
+
+;; (pending-timer AbsoluteSeconds Any Boolean)
+;; An outstanding timer being managed by the timer-driver.
+(struct pending-timer (deadline ;; Real
+		       label ;; TimerLabel
+		       )
+	#:transparent)
+
+(provide (struct-out set-timer)
+	 (struct-out timer-expired)
+	 timer-driver
+	 timer-relay)
+
+;; (define-type TimerKind (U 'relative 'absolute))
+
+;; The timer driver and timer relays listen for messages of this type,
+;; and when they hear one, they set an alarm that will later send a
+;; corresponding timer-expired message.
+(struct set-timer (label msecs kind) #:transparent)
+
+;; Message sent by the timer driver or a timer relay upon expiry of a
+;; timer. Contains the label specified in the corresponding set-timer
+;; message, and also the current absolute time from the outside world.
+(struct timer-expired (label msecs) #:transparent)
+
+;; State of a timer-driver, including the identifier of the driver,
+;; the currently-active subscription to ground time events (if any),
+;; and the heap of all remaining timers.
+(struct driver-state (heap) #:transparent)
+
+;; (define-type RelayKey Exact-Nonnegative-Integer)
+
+;; State of a timer-relay, including the next timer number and a
+;; mapping from timer number to timer label.
+(struct relay-state (next-counter ;; RelayKey
+		     active-timers ;; (HashTable RelayKey TimerLabel)
+		     )
+	#:transparent)
+
+;; (define-type RelayState relay-state)
+
+;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
+;; of (timer-expired 'current-time (current-inexact-milliseconds)),
+;; which can be used for an event-oriented interface to reading the
+;; system clock.
+
+;; Racket's alarm-evt is almost the right design for timeouts: its
+;; synchronisation value should be the (or some) value of the clock
+;; after the asked-for time. That way it serves as timeout and
+;; clock-reader in one.
+;; timer-evt : Real -> Evt
+(define (timer-evt msecs)
+  (wrap-evt (alarm-evt msecs)
+	    (lambda (_) (current-inexact-milliseconds))))
+
+;; make-timer-heap : -> Heap
+(define (make-timer-heap)
+  (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
+
+;; Retrieves the earliest-deadline timer from the heap, if there is
+;; one.
+;; next-timer! : Heap -> (Option pending-timer)
+(define (next-timer! heap)
+  (if (zero? (heap-count heap))
+      #f
+      (heap-min heap)))
+
+;; Retrieves (and removes) all timers from the heap that have deadline
+;; earlier or equal to the time passed in.
+;; fire-timers! : Heap Real -> (Listof SendMessage)
+(define (fire-timers! heap now)
+  (if (zero? (heap-count heap))
+      '()
+      (let ((m (heap-min heap)))
+	(if (<= (pending-timer-deadline m) now)
+	    (begin (heap-remove-min! heap)
+		   (cons (send-message (timer-expired (pending-timer-label m) now))
+			 (fire-timers! heap now)))
+	    '()))))
+
+;; Process for mapping this-level timer requests to ground-level timer
+;; events and back.
+;; timer-driver : (All (ParentState) -> (Spawn ParentState))
+(define (timer-driver)
+  (name-process 'timer-driver
+    (spawn (transition (driver-state (make-timer-heap))
+	     (subscriber (set-timer (wild) (wild) (wild))
+	       (match-state state
+		 (on-message
+		  [(set-timer label msecs 'relative)
+		   (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
+		  [(set-timer label msecs 'absolute)
+		   (install-timer! state label msecs)])))
+	     (publisher (timer-expired (wild) (wild)))))))
+
+;; install-timer! : DriverState TimerLabel Real -> (Transition DriverState)
+(define (install-timer! state label deadline)
+  (heap-add! (driver-state-heap state) (pending-timer deadline label))
+  (update-time-listener! state))
+
+;; update-time-listener! : DriverState -> (Transition DriverState)
+(define (update-time-listener! state)
+  (define next (next-timer! (driver-state-heap state)))
+  (transition state
+    (delete-endpoint 'time-listener)
+    (and next
+	 (name-endpoint 'time-listener
+	   (subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
+	     (match-state state
+	       (on-message
+		[(cons (? evt?) (? real? now))
+		 (let ((to-send (fire-timers! (driver-state-heap state) now)))
+		   ;; Note: compute to-send before recursing, because of side-effects on heap
+		   (sequence-actions (transition state)
+		     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)
+  (name-process `(timer-relay ,self-id)
+    (spawn (transition (relay-state 0 (make-immutable-hash '()))
+	     (at-meta-level
+	      (subscriber (timer-expired (wild) (wild))
+		(match-state (relay-state next-counter active-timers)
+		  (on-message
+		   [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
+				   now)
+		    (transition (relay-state next-counter (hash-remove active-timers counter))
+		      (and (hash-has-key? active-timers counter)
+			   (send-message (timer-expired (hash-ref active-timers counter)
+							now))))]))))
+	     (subscriber (set-timer (wild) (wild) (wild))
+	       (match-state (relay-state next-counter active-timers)
+		 (on-message
+		  [(set-timer label msecs kind)
+		   (transition (relay-state (+ next-counter 1)
+					    (hash-set active-timers next-counter label))
+		     (at-meta-level
+		      (send-message (set-timer (list self-id next-counter) msecs kind))))])))
+	     (publisher (timer-expired (wild) (wild)))))))

drivers/udp.rkt

@@ -0,0 +1,162 @@
+#lang racket/base
+;; UDP driver.
+
+(require racket/set)
+(require racket/match)
+(require racket/udp)
+
+(require "../sugar.rkt")
+
+(provide (struct-out udp-remote-address)
+	 (struct-out udp-handle)
+	 (struct-out udp-listener)
+
+	 udp-address?
+	 udp-local-address?
+
+	 (struct-out udp-packet)
+	 udp-driver)
+
+;; A UdpAddress is one of
+;; -- a (udp-address String Uint16), representing a remote socket
+;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
+;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
+;; Note that udp-handle-ids must be chosen carefully: they are scoped
+;; to the local VM, i.e. shared between processes in that VM, so
+;; processes must make sure not to accidentally clash in handle ID
+;; selection.
+(struct udp-remote-address (host port) #:transparent)
+(struct udp-handle (id) #:transparent)
+(struct udp-listener (port) #:transparent)
+
+(define (udp-address? x)
+  (or (udp-remote-address? x)
+      (udp-handle? x)
+      (udp-listener? x)))
+
+(define (udp-local-address? x)
+  (or (udp-handle? x)
+      (udp-listener? x)))
+
+;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
+;; represents a packet appearing on our local "subnet" of the full UDP
+;; network, complete with source, destination and contents.
+(struct udp-packet (source destination body) #:transparent)
+
+;; A HandleMapping is a record describing a mapping between a local
+;; UdpAddress and its underlying UDP socket. It's private to the
+;; implementation of the driver.
+(struct handle-mapping (address socket) #:transparent)
+
+;; TODO: BUG?: Routing packets between two local sockets won't work
+;; because the patterns aren't set up to recognise that situation.
+
+;; represents any remote address
+;; any-remote : UdpAddressPattern
+(define any-remote (udp-remote-address (wild) (wild)))
+
+;; (define-type DriverState (Setof UdpLocalAddress))
+
+;; (define-type SocketManagerState Boolean)
+
+;; Process acting as a UDP socket factory.
+;; udp-driver : (All (ParentState) -> (Spawn ParentState))
+(define (udp-driver)
+
+  ;; handle-presence : Topic DriverState -> (Transition DriverState)
+  (define (handle-presence topic active-handles)
+    (match-define (udp-packet _ (? udp-local-address? local-addr) _) topic)
+    (cond
+     [(set-member? active-handles local-addr)
+      (transition active-handles)]
+     [else
+      (transition (set-add active-handles local-addr)
+	(udp-socket-manager local-addr))]))
+
+  (name-process 'udp-driver
+    (spawn (transition (set)
+
+	     (observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
+	       (match-state active-handles
+		 (match-conversation topic
+		   (on-presence (handle-presence topic active-handles)))))
+	     (observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild))
+	       (match-state active-handles
+		 (match-conversation topic
+		   (on-presence (handle-presence topic active-handles)))))
+	     (observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
+	       (match-state active-handles
+		 (match-conversation topic
+		   (on-presence (handle-presence topic active-handles)))))
+	     (observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
+	       (match-state active-handles
+		 (match-conversation topic
+		   (on-presence (handle-presence topic active-handles)))))
+
+	     (observe-publishers (handle-mapping (wild) (wild))
+	       (match-state active-handles
+		 (match-conversation (handle-mapping local-addr socket)
+		   (on-absence
+		    (transition (set-remove active-handles local-addr))))))
+	     ))))
+
+;; bind-socket! : UDP-Socket UdpLocalAddress -> Void
+(define (bind-socket! s local-addr)
+  (match local-addr
+    [(udp-listener port) (udp-bind! s #f port)]
+    [(udp-handle _) (udp-bind! s #f 0)]
+    [else (void)]))
+
+;; valid-port-number? : Any -> Boolean : Natural
+(define (valid-port-number? x)
+  ;; Eventually TR will know about ranges
+  (exact-nonnegative-integer? x))
+
+;; udp-socket-manager : UdpLocalAddress -> (Spawn DriverState)
+(define (udp-socket-manager local-addr)
+  (define s (udp-open-socket #f #f))
+  (bind-socket! s local-addr)
+  (define buffer (make-bytes 65536)) ;; TODO: buffer size control
+
+  ;; handle-absence : SocketManagerState -> (Transition SocketManagerState)
+  (define (handle-absence socket-is-open?)
+    (transition #f
+      (quit)
+      (when socket-is-open?
+	(name-process `(udp-socket-closer ,local-addr)
+	  (spawn (begin (udp-close s)
+			(transition (void) (quit))))))))
+
+  (name-process `(udp-socket-manager ,local-addr)
+    (spawn (transition #t
+	      ;; Offers a handle-mapping on the local network so that
+	      ;; the driver/factory can clean up when this process dies.
+	      (publisher (handle-mapping local-addr s))
+	      ;; If our counterparty removes either of their endpoints
+	      ;; as the subscriber end of the remote-to-local stream or
+	      ;; the publisher end of the local-to-remote stream, shut
+	      ;; ourselves down. Also, relay messages published on the
+	      ;; local-to-remote stream out on the actual socket.
+	      (publisher (udp-packet any-remote local-addr (wild))
+		(match-state socket-is-open?
+		  (on-absence (handle-absence socket-is-open?))))
+	      (subscriber (udp-packet local-addr any-remote (wild))
+		(match-state socket-is-open?
+		  (on-absence (handle-absence socket-is-open?))
+		  (on-message
+		   [(udp-packet (== local-addr)
+				(udp-remote-address remote-host remote-port)
+				body)
+		    (begin (udp-send-to s remote-host remote-port body)
+			   (transition socket-is-open?))])))
+	      ;; Listen for messages arriving on the actual socket using
+	      ;; a ground event, and relay them at this level.
+	      (subscriber (cons (udp-receive!-evt s buffer) (wild))
+		(on-message
+		 [(cons (? evt?) (list (? exact-integer? packet-length)
+				       (? string? remote-host)
+				       (? valid-port-number? remote-port)))
+		  (let ((packet (subbytes buffer 0 packet-length)))
+		    (send-message (udp-packet (udp-remote-address remote-host remote-port)
+					      local-addr
+					      packet)))]))))))

examples/chat-client.rkt

@@ -0,0 +1,46 @@
+#lang marketplace
+
+(require racket/port)
+
+;; 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.
+(name-process 'console-output-driver
+  (spawn (transition/no-state
+	   (subscriber (list 'console-output ?)
+	     (on-message [(list 'console-output item)
+			  (printf "~a" item)
+			  (void)])))))
+
+(name-process 'console-input-driver
+  (spawn (transition/no-state
+	   (name-endpoint 'input-relay
+	     (publisher (list 'console-input ?)
+	       (on-absence
+		(send-message (list 'console-output "Connection terminated.\n"))
+		(quit))))
+	   (subscriber (cons (read-line-evt (current-input-port) 'any) ?)
+	     (on-message
+	      [(cons _ (? eof-object?))
+	       (send-message (list 'console-output "Terminating on local EOF.\n"))
+	       (delete-endpoint 'input-relay)]
+	      [(cons _ (? string? line))
+	       (send-message (list 'console-input line))])))))
+
+(name-process 'outbound-connection
+  (spawn (let ((local (tcp-handle 'outbound))
+	       (remote (tcp-address "localhost" 5999)))
+	   (transition/no-state
+	     (subscriber (list 'console-input ?)
+	       (on-absence (quit))
+	       (on-message
+		[(list 'console-input line)
+		 (send-message (list 'console-output (format "> ~a \n" line)))
+		 (send-message (tcp-channel local remote (string-append line "\n")))]))
+	     (publisher (tcp-channel local remote ?))
+	     (subscriber (tcp-channel remote local ?)
+	       (on-absence (quit))
+	       (on-message
+		[(tcp-channel _ _ (? eof-object?))
+		 (quit)]
+		[(tcp-channel _ _ data)
+		 (send-message (list 'console-output (format "< ~a" data)))]))))))

examples/chat-paper-raw.rkt

@@ -37,12 +37,6 @@
 
 (define (listen-to-user user them us)
   (list
-   (add-endpoint 'speech-publisher
-		 (role 'publisher
-		       `(,user says ,?)
-		       'participant)
-		 (lambda (event)
-		   (lambda (state) (transition state '()))))
    (at-meta-level
     (add-endpoint 'tcp-receiver
 		  (role 'subscriber
@@ -56,7 +50,13 @@
 		    (lambda (state)
 		      (transition state (send-message `(,user says ,text) 'publisher)))]
 		   [_
-		    (lambda (state) (transition state '()))])))))
+		    (lambda (state) (transition state '()))])))
+   (add-endpoint 'speech-publisher
+		 (role 'publisher
+		       `(,user says ,?)
+		       'participant)
+		 (lambda (event)
+		   (lambda (state) (transition state '()))))))
 
 (define (speak-to-user user them us)
   (define (say fmt . args)

examples/chat-paper.rkt

@@ -0,0 +1,46 @@
+#lang marketplace
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(spawn-vm
+ (at-meta-level
+  (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+    (match-conversation (tcp-channel them us _)
+      (on-presence (spawn (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
+   (at-meta-level
+    (subscriber (tcp-channel them us ?)
+      (on-absence (quit))
+      (on-message
+       [(tcp-channel _ _ (? bytes? text))
+        (send-message `(,user says ,text))])))
+   (publisher `(,user says ,?))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(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
+    (publisher (tcp-channel us them ?)))
+   (subscriber `(,? 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)])))))

examples/debug-chat.rkt

@@ -0,0 +1,47 @@
+#lang marketplace
+
+(require "../support/debug.rkt")
+
+(debug
+ (spawn-vm
+  (at-meta-level
+   (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+     (match-conversation (tcp-channel them us _)
+       (on-presence
+	(debug (name-process (list 'session them)
+		 (spawn (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
+   (publisher `(,user says ,?))
+   (at-meta-level
+    (subscriber (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
+    (publisher (tcp-channel us them ?)))
+   (subscriber `(,? 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)])))))

examples/echo-paper.rkt

@@ -0,0 +1,14 @@
+#lang marketplace
+
+(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+  (match-conversation (tcp-channel from to _)
+    (on-presence (spawn (echoer from to)))))
+
+(define (echoer from to)
+  (transition stateless
+    (publisher (tcp-channel to from ?))
+    (subscriber (tcp-channel from to ?)
+      (on-absence (quit))
+      (on-message
+       [(tcp-channel _ _ data)
+	(send-message (tcp-channel to from data))]))))

examples/echo-plain.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+;; Plain Racket version, using (require) instead of #lang marketplace.
+
+(require marketplace/sugar)
+(require marketplace/drivers/tcp-bare)
+
+(define (echoer from to)
+  (transition/no-state
+    (publisher (tcp-channel to from ?))
+    (subscriber (tcp-channel from to ?)
+      (on-absence (quit))
+      (on-message
+       [(tcp-channel _ _ data)
+	(send-message (tcp-channel to from data))]))))
+
+(ground-vm tcp
+	   (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+	     (match-conversation (tcp-channel from to _)
+	       (on-presence (spawn (echoer from to))))))

ground.rkt

@@ -1,25 +1,18 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log-typed.rkt")
+(require "log.rkt")
 (require "process.rkt")
 (require "actions.rkt")
 (require "action-send-message.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
-(require "support/event.rkt")
-
-(require/typed typed/racket/base
-	       [sync (Evt Evt * -> (vm -> vm))]
-	       [never-evt Evt]
-	       [always-evt Evt]
-	       [wrap-evt (Evt (Any -> (vm -> vm)) -> Evt)])
+(require "quasiqueue.rkt")
 
 (provide run-ground-vm)
 
-(: run-ground-vm : process-spec -> Void)
+;; run-ground-vm : process-spec -> Void
 (define (run-ground-vm boot)
   (let loop ((state (make-vm boot)))
     (match (run-vm state)
@@ -38,7 +31,7 @@
 		   "Cannot process meta-actions ~v because no further metalevel exists"
 		   actions)]))
        (define active-events
-	 ((inst endpoint-fold (Listof Evt)) extract-ground-event-subscriptions '() state))
+	 (endpoint-fold extract-ground-event-subscriptions '() state))
        (if (and is-blocking?
 		(null? active-events))
 	   (begin
@@ -49,27 +42,27 @@
 	   (let ((interruptk (apply sync
 				    (if is-blocking?
 					never-evt
-					(wrap-evt always-evt (lambda (dummy) (inst values vm))))
+					(wrap-evt always-evt (lambda (dummy) values)))
 				    active-events)))
 	     (loop (interruptk state))))])))
 
-(: extract-ground-event-subscriptions :
-   (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt)))
+;; extract-ground-event-subscriptions :
+;;    (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
 (define (extract-ground-event-subscriptions old-p ep acc)
   (define pid (process-pid old-p))
   (match (endpoint-role ep)
     [(role 'subscriber (cons (? evt? evt) _) 'participant)
-     (: evt-handler : Any -> vm -> vm)
+     ;; evt-handler : Any -> (vm -> vm)
      (define ((evt-handler message) state)
        (let-values (((state wp) (extract-process state pid)))
 	 (if (not wp)
 	     state
-	     (unwrap-process State vm (p wp)
+	     (let ((p wp))
 	       (let-values
 		   (((p state)
-		     (do-send-message 'publisher (cast (cons evt message) Message) p state)))
+		     (do-send-message 'publisher (cons evt message) p state)))
 		 (if p
-		     (inject-process state (mkProcess p))
+		     (inject-process state p)
 		     state))))))
      (cons (wrap-evt evt evt-handler) acc)]
     [_ acc]))

info.rkt

@@ -0,0 +1,10 @@
+#lang setup/infotab
+(define scribblings '(("scribblings/marketplace.scrbl" (multi-page))))
+(define deps '("base"
+               "data-lib"
+               "gui-lib"
+               "images-lib"
+               "rackunit-lib"))
+(define build-deps '("scribble-lib"
+                     "slideshow-lib"
+                     "typed-racket-lib"))

lang/base.rkt

@@ -3,13 +3,13 @@
 (require (for-syntax racket/base))
 (require (for-syntax racket/pretty))
 
-(require "../sugar-untyped.rkt")
+(require "../sugar.rkt")
 (require "../drivers/tcp-bare.rkt")
 (require "../support/spy.rkt")
 
 (provide (rename-out [module-begin #%module-begin])
 	 (except-out (all-from-out racket/base) #%module-begin)
-	 (all-from-out "../sugar-untyped.rkt")
+	 (all-from-out "../sugar.rkt")
 	 (all-from-out "../drivers/tcp-bare.rkt")
 	 (all-from-out "../support/spy.rkt")
 	 stateless)
@@ -48,7 +48,7 @@
 		(if (free-identifier=? #'head #'begin)
 		    (accumulate-actions action-ids
 					final-forms
-					(append (syntax->list #'(rest ...)) forms))
+					(append (syntax->list #'(rest ...)) (cdr forms)))
 		    (if (ormap (lambda (i) (free-identifier=? #'head i))
 			       (syntax->list #'(define-values define-syntaxes begin-for-syntax
 						 module module*

list-utils.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(provide list-max)
+
+;; list-max : (Listof Integer) -> Integer
+(define (list-max xs)
+  (foldr max 0 xs))

log.rkt

@@ -7,7 +7,6 @@
 
 (define marketplace-root-logger (make-logger 'marketplace #f))
 
-;; WARNING: duplicated in log-typed.rkt
 (define-syntax marketplace-log
   (syntax-rules ()
     [(_ level-exp message)

main.rkt

@@ -0,0 +1,27 @@
+#lang racket/base
+;; Virtualized operating system, this time with presence.
+
+;; TODO: contracts for State checking
+;; TODO: revisit exposure of PIDs to processes.
+;;        - make processes parametric in the PID type?
+;;        - simply make PIDs unavailable to processes?
+;;        - revisit points-of-attachment idea, and expose presence on PIDs properly?
+
+(require racket/match)
+(require "structs.rkt")
+(require "roles.rkt")
+(require "vm.rkt")
+(require "actions.rkt")
+(require "nested.rkt")
+(require "ground.rkt")
+(require "unify.rkt")
+
+(provide (all-from-out "structs.rkt")
+	 (all-from-out "roles.rkt")
+	 make-nested-vm
+	 run-ground-vm
+
+	 wild
+	 wild?
+	 non-wild?
+	 ground?)

marketplace/.gitignore

@@ -1 +0,0 @@
-doc/

marketplace/drivers/event-relay.rkt

@@ -1,33 +0,0 @@
-#lang typed/racket/base
-;; Ground-event relay.
-
-(provide event-relay)
-(require "../sugar-typed.rkt")
-(require "../support/event.rkt")
-
-(: event-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
-(define (event-relay self-id)
-  (spawn: #:debug-name `(event-relay ,self-id)
-	  #:parent : ParentState
-	  #:child : Void
-	  (transition/no-state
-	    (endpoint: : Void
-		       #:publisher (cons ? ?) #:observer
-		       #:conversation (cons (? evt? e) _)
-		       #:on-presence (begin
-				       (printf "SUBSCRIBED ~v~n" e)
-				       (flush-output)
-				       (at-meta-level
-					(endpoint: : Void
-						   #:subscriber (cons e ?)
-						   #:name `(event-relay ,self-id ,e)
-						   [msg
-						    (begin
-						      (printf "FIRED ~v -> ~v~n" e msg)
-						      (flush-output)
-						      (send-message msg))])))
-		       #:on-absence (begin
-				      (printf "UNSUBSCRIBED ~v~n" e)
-				      (flush-output)
-				      (at-meta-level
-				       (delete-endpoint `(event-relay ,self-id ,e))))))))

marketplace/drivers/tcp-bare.rkt

@@ -1,174 +0,0 @@
-#lang racket/base
-;; TCP drivers, ported from os2.rkt directly, with flow-control and line discipline removed
-
-(require racket/set)
-(require racket/match)
-(require (prefix-in tcp: racket/tcp))
-(require racket/port)
-(require "../sugar-untyped.rkt")
-(require "../support/dump-bytes.rkt")
-
-(provide (struct-out tcp-address)
-	 (struct-out tcp-handle)
-	 (struct-out tcp-listener)
-	 (struct-out tcp-channel)
-	 tcp
-	 tcp-driver)
-
-(struct tcp-address (host port) #:prefab)
-(struct tcp-handle (id) #:prefab)
-(struct tcp-listener (port) #:prefab)
-
-(struct tcp-channel (source destination subpacket) #:prefab)
-
-(define any-remote (tcp-address (wild) (wild)))
-(define any-handle (tcp-handle (wild)))
-(define any-listener (tcp-listener (wild)))
-
-(define (tcp-driver)
-  (spawn #:debug-name 'tcp-driver
-	 #:child
-   (transition (set)
-     (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:publisher  (tcp-channel any-remote any-listener (wild)) #:everything
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
-	       #:on-absence (maybe-forget-socket r active-handles))
-     (endpoint #:publisher  (tcp-channel any-remote any-handle (wild)) #:observer
-	       #:state active-handles
-	       #:role r
-	       #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
-	       #:on-absence (maybe-forget-socket r active-handles)))))
-
-(define tcp (tcp-driver)) ;; pre-instantiated!
-
-(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
-  (match r
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
-	 (role '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)
-		#:child (driver-fun local-addr remote-addr)))])]))
-
-;; Role Set<HandleMapping> -> Transition
-(define (maybe-forget-socket r active-handles)
-  (match r
-    [(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
-	 (role 'subscriber (tcp-channel remote-addr local-addr _) _))
-     (cond
-      [(ground? remote-addr) (transition active-handles)]
-      [(not (ground? local-addr)) (transition active-handles)]
-      [else (transition (set-remove active-handles local-addr))])]))
-
-;; TcpAddress TcpAddress -> Transition
-(define (tcp-listener-manager local-addr dummy-remote-addr)
-  (match-define (tcp-listener port) local-addr)
-  (define listener (tcp:tcp-listen port 4 #t))
-
-  (define (handle-absence r 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
-      [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
-	   (role '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)
-		      #:child
-		      (begin (tcp:tcp-close listener)
-			     (transition 'dummy (quit)))))))]))
-
-  (transition 'listener-is-running
-    (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
-	      #:state state
-	      #:role r
-	      #:on-absence (handle-absence r state))
-    (endpoint #:publisher  (tcp-channel any-remote local-addr (wild)) #:everything
-	      #:state state
-	      #:role r
-	      #:on-absence (handle-absence r state))
-    (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
-	      [(cons _ (list cin cout))
-	       (let-values (((local-hostname local-port remote-hostname remote-port)
-			     (tcp:tcp-addresses cin #t)))
-		 (define remote-addr (tcp-address remote-hostname remote-port))
-		 (spawn #:debug-name (cons local-addr remote-addr)
-			#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
-
-;; TcpAddress TcpAddress -> Transition
-(define (tcp-connection-manager local-addr remote-addr)
-  (match-define (tcp-address remote-hostname remote-port) remote-addr)
-  (define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
-  (tcp-connection-manager* local-addr remote-addr cin cout))
-
-(define (read-bytes-avail-evt len input-port)
-  (guard-evt
-   (lambda ()
-     (let ([bstr (make-bytes len)])
-       (wrap-evt
-        (read-bytes-avail!-evt bstr input-port)
-        (lambda (v)
-          (if (number? v)
-              (if (= v len) bstr (subbytes bstr 0 v))
-              v)))))))
-
-;; TcpAddress TcpAddress InputPort OutputPort -> Transition
-;;
-;; Our process state here is a Maybe<TcpConnectionState>, representing
-;; a shutting-down state if #f.
-(define (tcp-connection-manager* local-addr remote-addr cin cout)
-  (define (close-transition is-open send-eof?)
-    (transition #f
-      (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)
-		     #:child
-		     (begin (tcp:tcp-abandon-port cin)
-			    (tcp:tcp-abandon-port cout)
-			    (transition/no-state (quit))))))
-      (quit)))
-
-  (transition #t ;; open
-    (endpoint #:subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
-	      #:state is-open
-	      [(cons _ (? eof-object?)) (close-transition is-open #t)]
-	      [(cons _ (? bytes? bs)) (transition is-open (send-message (tcp-channel remote-addr local-addr bs)))])
-    (endpoint #:subscriber (cons (eof-evt cin) (wild))
-	      #:state is-open
-	      [(cons (? evt?) _) (close-transition is-open #t)])
-    (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
-	      #:state is-open
-	      #:on-absence (close-transition is-open #f)
-	      [(tcp-channel (== local-addr) (== remote-addr) subpacket)
-	       (match subpacket
-		 [(? eof-object?) (close-transition is-open #f)]
-		 [(? string? s) (begin (write-string s cout)
-				       (flush-output cout)
-				       (transition is-open))]
-		 [(? bytes? bs) (begin (write-bytes bs cout)
-				       (flush-output cout)
-				       (transition is-open))])])
-    (endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
-	      #:state is-open
-	      #:on-absence (close-transition is-open #f))))

marketplace/drivers/timer-untyped.rkt

@@ -1,13 +0,0 @@
-#lang racket/base
-;; Untyped-Racket support for Timer driver.
-
-(require "timer.rkt")
-(provide (except-out (all-from-out "timer.rkt")
-		     set-timer
-		     set-timer-pattern
-		     timer-expired
-		     timer-expired-pattern)
-	 (rename-out [set-timer-repr set-timer]
-		     [set-timer-repr set-timer-pattern]
-		     [timer-expired-repr timer-expired]
-		     [timer-expired-repr timer-expired-pattern]))

marketplace/drivers/timer.rkt

@@ -1,213 +0,0 @@
-#lang typed/racket/base
-;; Timer driver.
-
-;; Uses mutable state internally, but because the scope of the
-;; mutation is limited to each timer process alone, it's easy to show
-;; correct linear use of the various pointers.
-
-(require racket/set)
-(require racket/match)
-(require "../sugar-typed.rkt")
-(require "../support/event.rkt")
-(require "../support/pseudo-substruct.rkt")
-
-(require/typed typed/racket/base
-	       [wrap-evt (Evt (Any -> Real) -> Evt)])
-
-;; (pending-timer AbsoluteSeconds Any Boolean)
-;; An outstanding timer being managed by the timer-driver.
-(struct: pending-timer ([deadline : Real]
-			[label : TimerLabel])
-	 #:transparent)
-
-(require/typed data/heap
-	       [opaque Heap heap?]
-	       [make-heap ((pending-timer pending-timer -> Boolean) -> Heap)]
-	       [heap-count (Heap -> Exact-Nonnegative-Integer)]
-	       [heap-min (Heap -> pending-timer)]
-	       [heap-remove-min! (Heap -> Void)]
-	       [heap-add! (Heap pending-timer * -> Void)])
-
-(require/typed typed/racket/base
-	       [alarm-evt (Real -> Evt)])
-
-(provide TimerLabel
-	 TimerKind
-
-	 (struct-out set-timer-repr)
-	 SetTimer
-	 SetTimerPattern
-
-	 set-timer
-	 set-timer?
-	 set-timer-pattern
-	 set-timer-pattern?
-
-	 (struct-out timer-expired-repr)
-	 TimerExpired
-	 TimerExpiredPattern
-
-	 timer-expired
-	 timer-expired?
-	 timer-expired-pattern
-	 timer-expired-pattern?
-
-	 timer-driver
-	 timer-relay)
-
-(define-type TimerLabel Any)
-
-(define-type TimerKind (U 'relative 'absolute))
-
-;; The timer driver and timer relays listen for messages of this type,
-;; and when they hear one, they set an alarm that will later send a
-;; corresponding timer-expired message.
-(struct: (TLabel TMsecs TKind)
-	 set-timer-repr ([label : TLabel]
-			 [msecs : TMsecs]
-			 [kind : TKind])
-	 #:transparent)
-
-(pseudo-substruct: (set-timer-repr TimerLabel Real TimerKind)
-		   SetTimer set-timer set-timer?)
-(pseudo-substruct: (set-timer-repr (U Wild TimerLabel)
-				   (U Wild Real)
-				   (U Wild TimerKind))
-		   SetTimerPattern set-timer-pattern set-timer-pattern?)
-
-;; Message sent by the timer driver or a timer relay upon expiry of a
-;; timer. Contains the label specified in the corresponding set-timer
-;; message, and also the current absolute time from the outside world.
-(struct: (TLabel TMsecs)
-	 timer-expired-repr ([label : TLabel]
-			    [msecs : TMsecs])
-	 #:transparent)
-
-(pseudo-substruct: (timer-expired-repr TimerLabel Real)
-		   TimerExpired timer-expired timer-expired?)
-(pseudo-substruct: (timer-expired-repr (U Wild TimerLabel) (U Wild Real))
-		   TimerExpiredPattern timer-expired-pattern timer-expired-pattern?)
-
-;; State of a timer-driver, including the identifier of the driver,
-;; the currently-active subscription to ground time events (if any),
-;; and the heap of all remaining timers.
-(struct: driver-state ([heap : Heap]) #:transparent)
-
-(define-type DriverState driver-state)
-
-(define-type RelayKey Exact-Nonnegative-Integer)
-
-;; State of a timer-relay, including the next timer number and a
-;; mapping from timer number to timer label.
-(struct: relay-state ([next-counter : RelayKey]
-		      [active-timers : (HashTable RelayKey TimerLabel)])
-	 #:transparent)
-
-(define-type RelayState relay-state)
-
-;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
-;; of (timer-expired 'current-time (current-inexact-milliseconds)),
-;; which can be used for an event-oriented interface to reading the
-;; system clock.
-
-;; Racket's alarm-evt is almost the right design for timeouts: its
-;; synchronisation value should be the (or some) value of the clock
-;; after the asked-for time. That way it serves as timeout and
-;; clock-reader in one.
-(: timer-evt : Real -> Evt)
-(define (timer-evt msecs)
-  (wrap-evt (alarm-evt msecs)
-	    (lambda (_) (current-inexact-milliseconds))))
-
-(: make-timer-heap : -> Heap)
-(define (make-timer-heap)
-  (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
-
-;; Retrieves the earliest-deadline timer from the heap, if there is
-;; one.
-(: next-timer! : Heap -> (Option pending-timer))
-(define (next-timer! heap)
-  (if (zero? (heap-count heap))
-      #f
-      (heap-min heap)))
-
-;; Retrieves (and removes) all timers from the heap that have deadline
-;; earlier or equal to the time passed in.
-(: fire-timers! : Heap Real -> (Listof SendMessage))
-(define (fire-timers! heap now)
-  (if (zero? (heap-count heap))
-      '()
-      (let ((m (heap-min heap)))
-	(if (<= (pending-timer-deadline m) now)
-	    (begin (heap-remove-min! heap)
-		   (cons (send-message (timer-expired (pending-timer-label m) now))
-			 (fire-timers! heap now)))
-	    '()))))
-
-;; Process for mapping this-level timer requests to ground-level timer
-;; events and back.
-(: timer-driver : (All (ParentState) -> (Spawn ParentState)))
-(define (timer-driver)
-  (spawn: #:debug-name 'timer-driver
-	  #:parent : ParentState
-	  #:child : DriverState
-	  (transition: (driver-state (make-timer-heap)) : DriverState
-	    (endpoint: state : DriverState
-		       #:subscriber (set-timer-pattern (wild) (wild) (wild))
-		       [(set-timer label msecs 'relative)
-			(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
-		       [(set-timer label msecs 'absolute)
-			(install-timer! state label msecs)])
-	    (endpoint: : DriverState
-		       #:publisher (timer-expired-pattern (wild) (wild))))))
-
-(: install-timer! : DriverState TimerLabel Real -> (Transition DriverState))
-(define (install-timer! state label deadline)
-  (heap-add! (driver-state-heap state) (pending-timer deadline label))
-  (update-time-listener! state))
-
-(: update-time-listener! : DriverState -> (Transition DriverState))
-(define (update-time-listener! state)
-  (define next (next-timer! (driver-state-heap state)))
-  (transition: state : DriverState
-    (delete-endpoint 'time-listener)
-    (and next
-	 (endpoint: state : DriverState
-		    #:subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
-		    #:name 'time-listener
-		    [(cons (? evt?) (? real? now))
-		     (let ((to-send (fire-timers! (driver-state-heap state) now)))
-		     ;; Note: compute to-send before recursing, because of side-effects on heap
-		       (sequence-actions (transition: state : DriverState)
-					 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)
-	  #:parent : ParentState
-	  #:child : RelayState
-	  (transition: (relay-state 0 (make-immutable-hash '())) : RelayState
-	    (at-meta-level
-	     (endpoint: (relay-state next-counter active-timers) : RelayState
-			#:subscriber (timer-expired-pattern (wild) (wild))
-			[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
-					now)
-			 (transition: (relay-state next-counter (hash-remove active-timers counter))
-			     : RelayState
-			   (and (hash-has-key? active-timers counter)
-				(send-message (timer-expired (hash-ref active-timers counter)
-							     now))))]))
-	    (endpoint: (relay-state next-counter active-timers) : RelayState
-		       #:subscriber (set-timer-pattern (wild) (wild) (wild))
-		       [(set-timer label msecs kind)
-			(transition: (relay-state (+ next-counter 1)
-						  (hash-set active-timers next-counter label))
-			    : RelayState
-			  (at-meta-level: : RelayState
-			    (send-message (set-timer (list self-id next-counter) msecs kind))))])
-	    (endpoint: : RelayState
-		       #:publisher (timer-expired-pattern (wild) (wild))))))

marketplace/drivers/udp-untyped.rkt

@@ -1,21 +0,0 @@
-#lang racket/base
-;; UDP driver. Untyped macro wrappers
-
-(require "udp.rkt")
-(provide (except-out (all-from-out "udp.rkt")
-		     udp-remote-address
-		     udp-remote-address-pattern
-		     udp-handle
-		     udp-handle-pattern
-		     udp-listener
-		     udp-listener-pattern
-		     udp-packet
-		     udp-packet-pattern)
-	 (rename-out [udp-remote-address-repr udp-remote-address]
-		     [udp-remote-address-repr udp-remote-address-pattern]
-		     [udp-handle-repr udp-handle]
-		     [udp-handle-repr udp-handle-pattern]
-		     [udp-listener-repr udp-listener]
-		     [udp-listener-repr udp-listener-pattern]
-		     [udp-packet-repr udp-packet]
-		     [udp-packet-repr udp-packet-pattern]))

marketplace/drivers/udp.rkt

@@ -1,234 +0,0 @@
-#lang typed/racket/base
-;; UDP driver.
-
-(require racket/set)
-(require racket/match)
-
-(require "../support/event.rkt")
-(require (except-in racket/udp udp-receive!-evt))
-(require/typed racket/udp
-	       [udp-receive!-evt (UDP-Socket Bytes -> Evt)])
-
-(require "../sugar-typed.rkt")
-(require "../support/event.rkt")
-(require "../support/pseudo-substruct.rkt")
-
-(provide (struct-out udp-remote-address-repr)
-	 UdpRemoteAddress udp-remote-address udp-remote-address?
-	 UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?
-
-	 (struct-out udp-handle-repr)
-	 UdpHandle udp-handle udp-handle?
-	 UdpHandlePattern udp-handle-pattern udp-handle-pattern?
-
-	 (struct-out udp-listener-repr)
-	 UdpListener udp-listener udp-listener?
-	 UdpListenerPattern udp-listener-pattern udp-listener-pattern?
-
-	 UdpAddress
-	 UdpAddressPattern
-
-	 UdpLocalAddress
-
-	 udp-address?
-	 udp-address-pattern?
-	 udp-local-address?
-
-	 (struct-out udp-packet-repr)
-	 UdpPacket udp-packet udp-packet?
-	 UdpPacketPattern udp-packet-pattern udp-packet-pattern?
-
-	 udp-driver)
-
-;; A UdpAddress is one of
-;; -- a (udp-address String Uint16), representing a remote socket
-;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
-;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
-;; Note that udp-handle-ids must be chosen carefully: they are scoped
-;; to the local VM, i.e. shared between processes in that VM, so
-;; processes must make sure not to accidentally clash in handle ID
-;; selection.
-(struct: (THost TPort)
-	 udp-remote-address-repr ([host : THost]
-				  [port : TPort])
-	 #:transparent)
-(pseudo-substruct: (udp-remote-address-repr String Natural)
-		   UdpRemoteAddress udp-remote-address udp-remote-address?)
-(pseudo-substruct: (udp-remote-address-repr (U Wild String) (U Wild Natural))
-		   UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?)
-
-(struct: (TId)
-	 udp-handle-repr ([id : TId])
-	 #:transparent)
-(pseudo-substruct: (udp-handle-repr Any)
-		   UdpHandle udp-handle udp-handle?)
-(pseudo-substruct: (udp-handle-repr (U Wild Any))
-		   UdpHandlePattern udp-handle-pattern udp-handle-pattern?)
-
-(struct: (TPort)
-	 udp-listener-repr ([port : TPort])
-	 #:transparent)
-(pseudo-substruct: (udp-listener-repr Natural)
-		   UdpListener udp-listener udp-listener?)
-(pseudo-substruct: (udp-listener-repr (U Wild Natural))
-		   UdpListenerPattern udp-listener-pattern udp-listener-pattern?)
-
-(define-type UdpAddress (U UdpRemoteAddress UdpHandle UdpListener))
-(define-type UdpAddressPattern (U Wild UdpRemoteAddressPattern UdpHandlePattern UdpListenerPattern))
-
-(define-type UdpLocalAddress (U UdpHandle UdpListener))
-
-(define-predicate udp-address? UdpAddress)
-(define-predicate udp-address-pattern? UdpAddressPattern)
-(define-predicate udp-local-address? UdpLocalAddress)
-
-;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
-;; represents a packet appearing on our local "subnet" of the full UDP
-;; network, complete with source, destination and contents.
-(struct: (TSource TDestination TBody)
-	 udp-packet-repr ([source : TSource]
-			  [destination : TDestination]
-			  [body : TBody])
-	 #:transparent)
-(pseudo-substruct: (udp-packet-repr UdpAddress UdpAddress Bytes)
-		   UdpPacket udp-packet udp-packet?)
-(pseudo-substruct: (udp-packet-repr UdpAddressPattern UdpAddressPattern (U Wild Bytes))
-		   UdpPacketPattern udp-packet-pattern udp-packet-pattern?)
-
-;; A HandleMapping is a record describing a mapping between a local
-;; UdpAddress and its underlying UDP socket. It's private to the
-;; implementation of the driver.
-(struct: (TAddress TSocket)
-	 handle-mapping-repr ([address : TAddress]
-			      [socket : TSocket])
-	 #:transparent)
-(pseudo-substruct: (handle-mapping-repr UdpLocalAddress Any)
-		   ;; ^ TODO: Want to use UDP-Socket instead of Any here
-		   HandleMapping handle-mapping handle-mapping?)
-(pseudo-substruct: (handle-mapping-repr (U Wild UdpLocalAddress) (U Wild Any))
-		   HandleMappingPattern handle-mapping-pattern handle-mapping-pattern?)
-
-;; TODO: BUG?: Routing packets between two local sockets won't work
-;; because the patterns aren't set up to recognise that situation.
-
-;; represents any remote address
-(: any-remote : UdpAddressPattern)
-(define any-remote (udp-remote-address-pattern (wild) (wild)))
-
-(define-type DriverState (Setof UdpLocalAddress))
-
-(define-type SocketManagerState Boolean)
-
-;; Process acting as a UDP socket factory.
-(: udp-driver : (All (ParentState) -> (Spawn ParentState)))
-(define (udp-driver)
-
-  (: handle-presence : Topic DriverState -> (Transition DriverState))
-  (define (handle-presence topic active-handles)
-    (match-define (udp-packet-pattern _ (? udp-local-address? local-addr) _) topic)
-    (cond
-     [(set-member? active-handles local-addr)
-      (transition: active-handles : DriverState)]
-     [else
-      (transition: (set-add active-handles local-addr) : DriverState
-	(udp-socket-manager local-addr))]))
-
-  (spawn: #:debug-name 'udp-driver
-	  #:parent : ParentState
-	  #:child : DriverState
-	  (transition: ((inst set UdpLocalAddress)) : DriverState
-	    (endpoint: active-handles : DriverState
-		       #:publisher
-		       (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-		       #:observer
-		       #:conversation topic
-		       #:on-presence (handle-presence topic active-handles))
-	    (endpoint: active-handles : DriverState
-		       #:publisher
-		       (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
-		       #:observer
-		       #:conversation topic
-		       #:on-presence (handle-presence topic active-handles))
-	    (endpoint: active-handles : DriverState
-		       #:subscriber
-		       (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-		       #:observer
-		       #:conversation topic
-		       #:on-presence (handle-presence topic active-handles))
-	    (endpoint: active-handles : DriverState
-		       #:subscriber
-		       (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
-		       #:observer
-		       #:conversation topic
-		       #:on-presence (handle-presence topic active-handles))
-	    (endpoint: active-handles : DriverState
-		       #:subscriber (handle-mapping-pattern (wild) (wild))
-		       #:observer
-		       #: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)
-  (match local-addr
-    [(udp-listener port) (udp-bind! s #f port)]
-    [(udp-handle _) (udp-bind! s #f 0)]
-    [else (void)]))
-
-(: valid-port-number? : Any -> Boolean : Natural)
-(define (valid-port-number? x)
-  ;; Eventually TR will know about ranges
-  (exact-nonnegative-integer? x))
-
-(: udp-socket-manager : UdpLocalAddress -> (Spawn DriverState))
-(define (udp-socket-manager local-addr)
-  (define s (udp-open-socket #f #f))
-  (bind-socket! s local-addr)
-  (define buffer (make-bytes 65536)) ;; TODO: buffer size control
-
-  (: handle-absence : SocketManagerState -> (Transition SocketManagerState))
-  (define (handle-absence socket-is-open?)
-    (transition: #f : SocketManagerState
-      (quit)
-      (when socket-is-open?
-	(spawn: #:debug-name `(udp-socket-closer ,local-addr)
-		#:parent : SocketManagerState
-		#:child : Void
-		(begin (udp-close s)
-		       (transition: (void) : Void (quit)))))))
-
-  (spawn: #:debug-name `(udp-socket-manager ,local-addr)
-	  #:parent : DriverState
-	  #:child : SocketManagerState
-	  (transition: #t : SocketManagerState
-	    ;; Offers a handle-mapping on the local network so that
-	    ;; the driver/factory can clean up when this process dies.
-	    (endpoint: : SocketManagerState #:publisher (handle-mapping local-addr s))
-	    ;; If our counterparty removes either of their endpoints
-	    ;; as the subscriber end of the remote-to-local stream or
-	    ;; the publisher end of the local-to-remote stream, shut
-	    ;; ourselves down. Also, relay messages published on the
-	    ;; local-to-remote stream out on the actual socket.
-	    (endpoint: socket-is-open? : SocketManagerState
-		       #:publisher (udp-packet-pattern any-remote local-addr (wild))
-		       #:on-absence (handle-absence socket-is-open?))
-	    (endpoint: socket-is-open? : SocketManagerState
-		       #:subscriber (udp-packet-pattern local-addr any-remote (wild))
-		       #:on-absence (handle-absence socket-is-open?)
-		       [(udp-packet (== local-addr)
-				    (udp-remote-address remote-host remote-port)
-				    body)
-			(begin (udp-send-to s remote-host remote-port body)
-			       (transition: socket-is-open? : SocketManagerState))])
-	    ;; Listen for messages arriving on the actual socket using
-	    ;; a ground event, and relay them at this level.
-	    (endpoint: : SocketManagerState
-		       #:subscriber (cons (udp-receive!-evt s buffer) (wild))
-		       [(cons (? evt?) (list (? exact-integer? packet-length)
-					     (? string? remote-host)
-					     (? valid-port-number? remote-port)))
-			(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

@@ -1,47 +0,0 @@
-#lang marketplace
-
-(require racket/port)
-
-;; 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
-       #:child
-       (transition/no-state
-	(endpoint #:subscriber (list 'console-output ?)
-		  [(list 'console-output item)
-		   (begin (printf "~a" item)
-			  (void))])))
-
-(spawn #:debug-name 'console-input-driver
-       #:child
-       (transition/no-state
-	(endpoint #:publisher (list 'console-input ?)
-		  #:name 'input-relay
-		  #:on-absence
-		  (list (send-message (list 'console-output "Connection terminated.\n"))
-			(quit)))
-	(endpoint #:subscriber (cons (read-line-evt (current-input-port) 'any) ?)
-		  [(cons _ (? eof-object?))
-		   (list (send-message (list 'console-output "Terminating on local EOF.\n"))
-			 (delete-endpoint 'input-relay))]
-		  [(cons _ (? string? line))
-		   (send-message (list 'console-input line))])))
-
-(spawn #:debug-name 'outbound-connection
-       #:child
-       (let ((local (tcp-handle 'outbound))
-	     (remote (tcp-address "localhost" 5999)))
-	 (transition/no-state
-	  (endpoint #:subscriber (list 'console-input ?)
-		    #:on-absence (quit)
-		    [(list 'console-input line)
-		     (list (send-message (list 'console-output (format "> ~a \n" line)))
-			   (send-message (tcp-channel local remote (string-append line "\n"))))])
-	  (endpoint #:publisher (tcp-channel local remote ?))
-	  (endpoint #:subscriber (tcp-channel remote local ?)
-		    #:on-absence (quit)
-		    [(tcp-channel _ _ (? eof-object?))
-		     (quit)]
-		    [(tcp-channel _ _ data)
-		     (list (send-message (list 'console-output (format "< ~a" data)))
-			   (void))]))))

marketplace/examples/chat-paper.rkt

@@ -1,43 +0,0 @@
-#lang marketplace
-
-(nested-vm
- (at-meta-level
-  (endpoint
-   #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
-   #:observer
-   #: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 ,?))
-   (at-meta-level
-    (endpoint #:subscriber (tcp-channel them us ?)
-              #:on-absence (quit)
-              [(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
-    (endpoint #:publisher (tcp-channel us them ?)))
-   (endpoint #:subscriber `(,? says ,?)
-     #:conversation `(,who says ,_)
-     #:on-presence (announce who 'arrived)
-     #:on-absence  (announce who 'departed)
-     [`(,who says ,what) (say "~a: ~a" who what)])))

marketplace/examples/debug-chat.rkt

@@ -1,49 +0,0 @@
-#lang marketplace
-
-(require "../support/debug.rkt")
-
-(debug
- (nested-vm
-  #:debug-name 'echo
-  (at-meta-level
-   (endpoint
-    #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
-    #:observer
-    #:conversation (tcp-channel them us _)
-    #:on-presence
-    (debug
-     (spawn #:debug-name (list 'session them)
-	    #: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 ,?))
-   (at-meta-level
-    (endpoint #:subscriber (tcp-channel them us ?)
-              #:on-absence (quit)
-              [(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
-    (endpoint #:publisher (tcp-channel us them ?)))
-   (endpoint #:subscriber `(,? says ,?)
-     #:conversation `(,who says ,_)
-     #:on-presence (announce who 'arrived)
-     #:on-absence  (announce who 'departed)
-     [`(,who says ,what) (say "~a: ~a" who what)])))

marketplace/examples/echo-paper.rkt

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

marketplace/examples/echo-plain.rkt

@@ -1,18 +0,0 @@
-#lang racket/base
-;; Plain Racket version, using (require) instead of #lang marketplace.
-
-(require marketplace/sugar-untyped)
-(require marketplace/drivers/tcp-bare)
-
-(define (echoer from to)
-  (transition/no-state
-    (endpoint
-      #:subscriber (tcp-channel from to ?)
-      #:on-absence (quit)
-      [(tcp-channel _ _ data)
-       (send-message (tcp-channel to from data))])))
-
-(ground-vm tcp
-	   (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
-		     #:conversation (tcp-channel from to _)
-		     #:on-presence (spawn #:child (echoer from to))))

marketplace/info.rkt

@@ -1,2 +0,0 @@
-#lang setup/infotab
-(define scribblings '(("scribblings/marketplace.scrbl" (multi-page))))

marketplace/list-utils.rkt

@@ -1,7 +0,0 @@
-#lang typed/racket/base
-
-(provide list-max)
-
-(: list-max : (Listof Integer) -> Integer)
-(define (list-max xs)
-  (foldr max 0 xs))

marketplace/log-typed.rkt

@@ -1,17 +0,0 @@
-#lang typed/racket/base
-
-(require/typed "log-untyped.rkt"
-	       [marketplace-root-logger Logger])
-
-;; WARNING: duplicated in log-untyped.rkt
-(define-syntax marketplace-log
-  (syntax-rules ()
-    [(_ level-exp message)
-     (let ((level level-exp))
-       (when (log-level? marketplace-root-logger level)
-	 (log-message marketplace-root-logger level message #f)))]
-    [(_ level format-string exp ...)
-     (marketplace-log level (format format-string exp ...))]))
-
-(provide marketplace-root-logger
-	 marketplace-log)

marketplace/main.rkt

@@ -1,35 +0,0 @@
-#lang typed/racket/base
-;; Virtualized operating system, this time with presence and types.
-
-;; TODO: contracts for State checking
-;; TODO: types for Message and MetaMessage (will require rethinking at-meta-level spawn)
-;; TODO: revisit exposure of PIDs to processes.
-;;        - make processes parametric in the PID type?
-;;        - simply make PIDs unavailable to processes?
-;;        - revisit points-of-attachment idea, and expose presence on PIDs properly?
-
-(require racket/match)
-(require "types.rkt")
-(require "roles.rkt")
-(require "vm.rkt")
-(require "actions.rkt")
-(require "nested.rkt")
-(require "ground.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
-
-(require/typed "unify.rkt"
-	       [opaque Wild wild?]
-	       [wild (case-> (-> Wild) (Symbol -> Wild))]
-	       [non-wild? (Any -> Boolean)]
-	       [ground? (Any -> Boolean)])
-
-(provide (all-from-out "types.rkt")
-	 (all-from-out "roles.rkt")
-	 make-nested-vm
-	 run-ground-vm
-
-	 Wild
-	 wild
-	 wild?
-	 non-wild?
-	 ground?)

marketplace/opaque-any.rkt

@@ -1,9 +0,0 @@
-#lang racket/base
-
-(provide topic?
-	 pre-eid?
-	 reason?)
-
-(define (topic? x) #t)
-(define (pre-eid? x) #t)
-(define (reason? x) #t)

marketplace/quasiqueue.rkt

@@ -1,51 +0,0 @@
-#lang typed/racket/base
-
-(provide QuasiQueue
-	 Constreeof
-	 empty-quasiqueue
-	 quasiqueue-empty?
-	 quasiqueue-append-list
-	 quasiqueue-append
-	 quasiqueue
-	 list->quasiqueue
-	 quasiqueue->list
-	 quasiqueue->cons-tree)
-
-;; A QuasiQueue<X> is a list of Xs in *reversed* order.
-(define-type (QuasiQueue X) (Listof X))
-
-(define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null)))
-
-(: empty-quasiqueue : (All (X) -> (QuasiQueue X)))
-(define (empty-quasiqueue) '())
-
-(: quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean))
-(define (quasiqueue-empty? q) (null? q))
-
-(: quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X)))
-(define (quasiqueue-append-list q xs)
-  (append (reverse xs) q))
-
-(: quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X)))
-(define (quasiqueue-append q1 q2)
-  (append q2 q1))
-
-(: quasiqueue : (All (X) X * -> (QuasiQueue X)))
-(define (quasiqueue . xs)
-  (reverse xs))
-
-(: list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X)))
-(define (list->quasiqueue xs)
-  (reverse xs))
-
-(: quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X)))
-(define (quasiqueue->list q)
-  (reverse q))
-
-(: quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X)))
-(define (quasiqueue->cons-tree q)
-  ;; (reverse q) -- can't use this, TR won't prove Listof X <: Constreeof X.
-  (let loop ((#{acc : (Constreeof X)} '()) (q q))
-    (if (null? q)
-	acc
-	(loop (cons (car q) acc) (cdr q)))))

marketplace/scribblings/examples.scrbl

@@ -1,133 +0,0 @@
-#lang scribble/manual
-@require[racket/include]
-@include{prelude.inc}
-
-@title{Examples}
-
-@section[#:tag "echo-server-example"]{TCP echo server}
-
-Here is a complete Marketplace program:
-
-@#reader scribble/comment-reader (racketmod #:file "examples/echo-paper.rkt" marketplace
-
-(endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
-	  #:conversation (tcp-channel from to _)
-	  #:on-presence (spawn #:child (echoer from to)))
-
-(define (echoer from to)
-  (transition stateless
-    (endpoint #:subscriber (tcp-channel from to ?)
-	      #:on-absence (quit)
-	      [(tcp-channel _ _ data)
-	       (send-message (tcp-channel to from data))])))
-)
-
-The top-level @racket[endpoint] action subscribes to TCP connections
-arriving on port 5999, and @racket[spawn]s a fresh process in response to
-each (@racket[#:on-presence]). The topic of
-conversation (@racket[#:conversation]) associated with the newly-present
-subscription is analyzed to give the remote
-(@racket[from]) and local (@racket[to]) TCP addresses, which are
-passed to the @racket[echoer] function to give the initial actions for
-the corresponding process. Here, the process is stateless, using the
-special constant @racket[stateless] as its state.
-
-Each connection's process creates an endpoint subscribing to data
-arriving on its particular connection, using @racket[from] and @racket[to]
-passed in from the top-level @racket[endpoint]. When data arrives, it is
-echoed back to the remote peer using @racket[send-message]. Presence
-manages disconnection; when the remote peer closes the TCP connection,
-the @racket[#:on-absence] handler in @racket[echoer] issues a @racket[quit]
-action, terminating the connection's process. The heart of our system
-is the interface between a process and its containing VM. Our
-implementation instantiates this interface as a collection of Typed
-Racket programs.
-
-@section[#:tag "chat-server-example"]{TCP chat server}
-
-@#reader scribble/comment-reader (racketmod #:file "examples/chat-paper.rkt" marketplace
-
-(nested-vm
- (at-meta-level
-  (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?) #:observer
-	    #: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 ,?))
-   (at-meta-level
-    (endpoint #:subscriber (tcp-channel them us ?)
-	      #:on-absence (quit)
-	      [(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
-    (endpoint #:publisher (tcp-channel us them ?)))
-   (endpoint #:subscriber `(,? says ,?)
-	     #:conversation `(,who says ,_)
-	     #:on-presence (announce who 'arrived)
-	     #:on-absence  (announce who 'departed)
-	     [`(,who says ,what) (say "~a: ~a" who what)])))
-)
-
-@section[#:tag "chat-client-example"]{TCP chat client}
-
-@#reader scribble/comment-reader (racketmod #:file "examples/chat-client.rkt" marketplace
-(require racket/port)
-
-(spawn #:debug-name 'console-output-driver
-       #:child
-       (transition/no-state
-	(endpoint #:subscriber (list 'console-output ?)
-		  [(list 'console-output item)
-		   (begin (printf "~a" item)
-			  (void))])))
-
-(spawn #:debug-name 'console-input-driver
-       #:child
-       (transition/no-state
-	(endpoint #:publisher (list 'console-input ?)
-		  #:name 'input-relay
-		  #:on-absence
-		  (list (send-message (list 'console-output "Connection terminated.\n"))
-			(quit)))
-	(endpoint #:subscriber (cons (read-line-evt (current-input-port) 'any) ?)
-		  [(cons _ (? eof-object?))
-		   (list (send-message (list 'console-output "Terminating on local EOF.\n"))
-			 (delete-endpoint 'input-relay))]
-		  [(cons _ (? string? line))
-		   (send-message (list 'console-input line))])))
-
-(spawn #:debug-name 'outbound-connection
-       #:child
-       (let ((local (tcp-handle 'outbound))
-	     (remote (tcp-address "localhost" 5999)))
-	 (transition/no-state
-	  (endpoint #:subscriber (list 'console-input ?)
-		    #:on-absence (quit)
-		    [(list 'console-input line)
-		     (list (send-message (list 'console-output (format "> ~a \n" line)))
-			   (send-message (tcp-channel local remote (string-append line "\n"))))])
-	  (endpoint #:publisher (tcp-channel local remote ?))
-	  (endpoint #:subscriber (tcp-channel remote local ?)
-		    #:on-absence (quit)
-		    [(tcp-channel _ _ (? eof-object?))
-		     (quit)]
-		    [(tcp-channel _ _ data)
-		     (list (send-message (list 'console-output (format "< ~a" data)))
-			   (void))]))))
-)

marketplace/sugar-typed.rkt

@@ -1,212 +0,0 @@
-#lang typed/racket/base
-
-(require (for-syntax syntax/parse))
-(require (for-syntax racket/base))
-
-(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
-		    wild))
-(require "sugar-values.rkt")
-
-(provide (all-from-out "sugar-values.rkt")
-	 (all-from-out "main.rkt")
-	 ?
-	 transition:
-	 transition/no-state
-	 endpoint:
-	 spawn:
-	 yield:
-	 at-meta-level:
-	 nested-vm:
-	 ground-vm:)
-
-;; A fresh unification variable, as identifier-syntax.
-(define-syntax ? (syntax-id-rules () (_ (wild))))
-
-(define-syntax transition:
-  (lambda (stx)
-    (syntax-case stx (:)
-      [(_ state : State action ...)
-       #'((inst transition State) state action ...)])))
-
-(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")
-	       (~optional (~seq #:debug-name debug-name)
-			  #: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)
-			       (lambda (k) ((inst k State) exp))))
-	  #,(if (attribute parent-k-exp)
-		(if (attribute parent-state-pattern)
-		    #`(lambda (pid)
-			(lambda: ([parent-state : ParentState])
-			  (match parent-state [parent-state-pattern parent-k-exp])))
-		    #`(lambda (pid)
-			(lambda: ([parent-state : ParentState])
-			  ((inst core:transition ParentState) parent-state parent-k-exp))))
-		#'#f)
-	  debug-name)])))
-
-(define-syntax yield:
-  (lambda (stx)
-    (syntax-case stx (:)
-      [(_ state-pattern : State 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 (:)
-      [(_ : State preaction ...)
-       #'((inst at-meta-level State) preaction ...)])))
-
-(define-syntax nested-vm:
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~literal :) ParentState
-	  (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
-			  #:name "#:vm-pid")
-	       (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
-			  #:name "#:boot-pid")
-	       (~optional (~seq #:initial-state initial-state (~literal :) InitialState)
-			  #:defaults ([initial-state #'(void)] [InitialState #'Void])
-			  #:name "#:initial-state")
-	       (~optional (~seq #:debug-name debug-name)
-			  #:defaults ([debug-name #'#f])
-			  #:name "#:debug-name"))
-	  ...
-	  exp ...)
-       #`((inst core:make-nested-vm ParentState)
-	  (lambda (vm-pid)
-	    (core:process-spec (lambda (boot-pid)
-				 (lambda (k) ((inst k InitialState)
-					      (core:transition initial-state
-							       (list exp ...)))))))
-	  debug-name)])))
-
-(define-syntax ground-vm:
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
-			  #:name "#:boot-pid")
-	       (~optional (~seq #:initial-state initial-state (~literal :) InitialState)
-			  #:defaults ([initial-state #'(void)] [InitialState #'Void])
-			  #:name "#:initial-state"))
-	  ...
-	  exp ...)
-       #`(core:run-ground-vm
-	  (core:process-spec (lambda (boot-pid)
-			       (lambda (k) ((inst k InitialState)
-					    (core:transition initial-state
-							     (list exp ...)))))))])))
-
-;;; Local Variables:
-;;; eval: (put 'at-meta-level: 'scheme-indent-function 2)
-;;; End:

marketplace/sugar-untyped.rkt

@@ -1,181 +0,0 @@
-#lang racket/base
-
-(require (for-syntax syntax/parse))
-(require (for-syntax racket/base))
-
-(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-values.rkt")
-
-(provide (all-from-out "sugar-values.rkt")
-	 (all-from-out "main.rkt")
-	 ?
-	 transition/no-state
-	 endpoint
-	 spawn
-	 yield
-	 nested-vm
-	 ground-vm)
-
-(define-syntax-rule (transition/no-state action ...)
-  (transition (void) action ...))
-
-;; 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")
-	       (~optional (~seq #:debug-name debug-name)
-			  #:defaults ([debug-name #'#f])
-			  #:name "#:debug-name")) ...
-	  (~or (~seq #:parent parent-state-pattern (~and (~not #:child) parent-k-exp))
-	       (~seq #:parent (~and (~not #:child) parent-k-exp))
-	       (~seq))
-	  #:child exp)
-       #`(core:spawn (core:process-spec (lambda (pid)
-					  (lambda (k) (k exp))))
-		     #,(if (attribute parent-k-exp)
-			   (if (attribute parent-state-pattern)
-			       #`(lambda (pid)
-				   (match-lambda [parent-state-pattern parent-k-exp]))
-			       #`(lambda (pid)
-				   (lambda (state)
-				     (core:transition state parent-k-exp))))
-			   #'#f)
-		     debug-name)])))
-
-(define-syntax yield
-  (lambda (stx)
-    (syntax-case stx ()
-      [(_ #:state state-pattern exp)
-       #'(core:yield (match-lambda [state-pattern exp]))]
-      [(_ exp)
-       #'(core:yield (lambda (state) (core:transition state exp)))])))
-
-(define-syntax nested-vm
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
-			  #:name "#:vm-pid")
-	       (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
-			  #:name "#:boot-pid")
-	       (~optional (~seq #:initial-state initial-state)
-			  #:defaults ([initial-state #'(void)])
-			  #:name "#:initial-state")
-	       (~optional (~seq #:debug-name debug-name)
-			  #:defaults ([debug-name #'#f])
-			  #:name "#:debug-name"))
-	  ...
-	  exp ...)
-       #`(core:make-nested-vm
-	  (lambda (vm-pid)
-	    (core:process-spec (lambda (boot-pid)
-				 (lambda (k) (k (core:transition initial-state
-								 (list exp ...)))))))
-	  debug-name)])))
-
-(define-syntax ground-vm
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
-			  #:name "#:boot-pid")
-	       (~optional (~seq #:initial-state initial-state)
-			  #:defaults ([initial-state #'(void)])
-			  #:name "#:initial-state"))
-	  ...
-	  exp ...)
-       #`(core:run-ground-vm
-	  (core:process-spec (lambda (boot-pid)
-			       (lambda (k) (k (core:transition initial-state
-							       (list exp ...)))))))])))

marketplace/sugar-values.rkt

@@ -1,87 +0,0 @@
-#lang typed/racket/base
-
-(require racket/match)
-(require (prefix-in core: "main.rkt"))
-
-(provide transition
-	 at-meta-level
-	 delete-endpoint
-	 send-message
-	 send-feedback
-	 quit
-	 sequence-actions
-	 (rename-out [core:wild wild]))
-
-(: transition : (All (State) State (core:ActionTree State) * -> (core:Transition State)))
-(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)))
-
-(: send-message : (case-> [Any -> core:send-message]
-			  [Any core:Orientation -> core:send-message]))
-(define (send-message body [#{orientation : core:Orientation} 'publisher])
-  (core:send-message (cast body core:Message) orientation))
-
-(define (send-feedback #{body : Any})
-  (core:send-message (cast body core:Message) 'subscriber))
-
-(: quit : (case-> [-> core:quit]
-		  [(Option core:PID) -> core:quit]
-		  [(Option core:PID) Any -> core:quit]))
-(define (quit [#{who : (Option core:PID)} (ann #f (Option core:PID))]
-	      [#{reason : Any} #f])
-  (core:quit who (cast reason core:Reason)))
-
-(: sequence-actions : (All (State)
-			   (core:Transition State)
-			   (U (core:ActionTree State) (State -> (core:Transition State))) *
-			   -> (core:Transition State)))
-(define (sequence-actions t . more-actions-and-transformers)
-  (match-define (core:transition initial-state initial-actions) t)
-  (let loop ((state initial-state)
-	     (actions initial-actions)
-	     (items more-actions-and-transformers))
-    (match items
-      ['()
-       (core:transition state actions)]
-      [(cons item remaining-items)
-       (if (or (pair? item)
-	       (eq? item #f)
-	       (void? item)
-	       (null? item)
-	       (core:add-endpoint? item)
-	       (core:delete-endpoint? item)
-	       (core:send-message? item)
-	       (core:spawn? item)
-	       (core:quit? item)
-	       (core:yield? item)
-	       (core:at-meta-level? item))
-	   ;; ^ This is ugly, but necessary to let Typed Racket
-	   ;; correctly deduce the type of item in the expression
-	   ;; (item state) in the false branch of this conditional.
-	   ;; Because the type Action is parameterized, there's no
-	   ;; sensible way of factoring out the big or here into a
-	   ;; reusable predicate.
-	   (loop state
-		 ((inst cons (core:ActionTree State) (core:ActionTree State))
-		  actions
-		  item)
-		 remaining-items)
-	   (match (item state)
-	     [(core:transition new-state more-actions)
-	      (loop new-state
-		    (cons actions more-actions)
-		    remaining-items)]))])))
-
-;;; eval: (put 'sequence-actions 'scheme-indent-function 1)

marketplace/support/debug.rkt

@@ -1,109 +0,0 @@
-#lang typed/racket/base
-
-(require racket/match)
-
-(require (prefix-in core: "../main.rkt"))
-(require "../sugar-typed.rkt")
-(require "../vm.rkt")
-(require "../process.rkt")
-(require "../quasiqueue.rkt")
-
-(require/typed "gui.rkt"
-	       [open-debugger (Any -> Debugger)])
-
-(define-type Debugger (All (S) (S -> S)))
-
-(provide debug)
-
-(: debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState)))
-(define (debug spawn-child)
-  (match-define (core:spawn child-spec parent-k debug-name) spawn-child)
-  (core:spawn
-   (process-spec
-    (lambda: ([pid : PID]) ;; TODO: exploit this more in messages etc.
-      (define original-cotransition ((process-spec-boot child-spec) pid))
-      (: wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R))
-      (define (wrapped-cotransition k)
-	(: receiver : (All (S) (Transition S) -> R))
-	(define (receiver child-transition)
-	  (define d (open-debugger debug-name))
-	  ((inst k S) (wrap-transition d child-transition)))
-	((inst original-cotransition R) receiver))
-      wrapped-cotransition))
-   parent-k
-   (list 'debug debug-name)))
-
-(: wrap-transition : (All (ChildState)
-			  Debugger
-			  (Transition ChildState)
-			  -> (Transition ChildState)))
-(define (wrap-transition d child-transition0)
-  (define child-transition ((inst d (Transition ChildState)) child-transition0))
-  (match-define (core:transition child-state child-actions) child-transition)
-  (core:transition child-state ((inst action-tree-map ChildState)
-				(wrap-action d)
-				child-actions)))
-
-(: action-tree-map : (All (State) ((Action State) -> (Action State))
-			  (ActionTree State)
-			  -> (ActionTree State)))
-(define (action-tree-map f actions)
-  ((inst map (Action State) (Action State))
-   f
-   (quasiqueue->list (action-tree->quasiqueue actions))))
-
-(: wrap-action : (All (ChildState)
-		      Debugger
-		      -> ((Action ChildState) -> (Action ChildState))))
-(define ((wrap-action d) action)
-  (cond
-   [(core:yield? action)
-    (core:yield (wrap-interruptk d (core:yield-k action)))]
-   [(core:at-meta-level? action)
-    (core:at-meta-level (wrap-preaction #t d (core:at-meta-level-preaction action)))]
-   [else
-    (wrap-preaction #f d action)]))
-
-(: wrap-preaction : (All (ChildState)
-			 Boolean
-			 Debugger
-			 (PreAction ChildState)
-			 -> (PreAction ChildState)))
-(define (wrap-preaction meta? d preaction)
-  (match preaction
-    [(core:add-endpoint pre-eid role handler)
-     (core:add-endpoint pre-eid role (wrap-handler meta? d handler))]
-    [(core:delete-endpoint pre-eid reason)
-     preaction]
-    [(core:send-message body orientation)
-     preaction]
-    [(core:spawn spec maybe-k child-debug-name)
-     (core:spawn spec (wrap-spawnk d maybe-k) child-debug-name)]
-    [(core:quit pid reason)
-     preaction]))
-
-(: wrap-interruptk : (All (ChildState)
-			  Debugger
-			  (InterruptK ChildState)
-			  -> (InterruptK ChildState)))
-(define (wrap-interruptk d ik)
-  (lambda (state)
-    (wrap-transition d (ik state))))
-
-(: wrap-spawnk : (All (ChildState)
-		      Debugger
-		      (Option (PID -> (InterruptK ChildState)))
-		      -> (Option (PID -> (InterruptK ChildState)))))
-(define (wrap-spawnk d maybe-k)
-  (and maybe-k
-       (lambda: ([child-pid : PID]) (wrap-interruptk d (maybe-k child-pid)))))
-
-(: wrap-handler : (All (ChildState)
-		       Boolean
-		       Debugger
-		       (Handler ChildState)
-		       -> (Handler ChildState)))
-(define (wrap-handler meta?0 d h)
-  (lambda (event0)
-    (match-define (cons meta? event) ((inst d (Pairof Boolean EndpointEvent)) (cons meta?0 event0)))
-    (wrap-interruptk d (h event))))

marketplace/support/event.rkt

@@ -1,7 +0,0 @@
-#lang typed/racket/base
-
-(require/typed typed/racket/base
-	       [opaque Evt evt?])
-
-(provide Evt
-	 evt?)

marketplace/support/pseudo-substruct.rkt

@@ -1,18 +0,0 @@
-#lang typed/racket/base
-;; Limited support for reasoning about subtyped of a polymorphic base struct type in TR.
-
-(require (for-syntax racket/base))
-(require racket/match)
-
-(provide pseudo-substruct:)
-
-(define-syntax-rule (pseudo-substruct: (super-type TypeParam ...) SubType sub-type sub-type?)
-  (begin (define-type SubType (super-type TypeParam ...))
-	 (define-predicate sub-type? SubType)
-	 (define-match-expander sub-type
-	   (lambda (stx)
-	     (syntax-case stx () [(_ f (... ...)) #'(? sub-type? (super-type f (... ...)))]))
-	   (lambda (stx)
-	     (syntax-case stx ()
-	       [x (identifier? #'x) #'(inst super-type TypeParam ...)]
-	       [(_ f (... ...)) #'((inst super-type TypeParam ...) f (... ...))])))))

marketplace/support/spy.rkt

@@ -1,32 +0,0 @@
-#lang typed/racket/base
-
-(require "../sugar-typed.rkt")
-
-(provide generic-spy)
-
-(: generic-spy : (All (ParentState) Any -> (Spawn ParentState)))
-(define (generic-spy label)
-  (spawn: #:debug-name `(generic-spy ,label)
-	  #:parent : ParentState
-	  #:child : Void
-	  (transition: (void) : Void
-	    (endpoint: : Void
-		       #:subscriber (wild) #:observer
-		       #:peer-orientation orientation
-		       #:conversation topic
-		       #:peer-interest-type interest
-		       #:reason reason
-		       #:on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
-					    (newline)
-					    (flush-output)
-					    '())
-		       #:on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
-					   (newline)
-					   (display reason)
-					   (newline)
-					   (flush-output)
-					   '())
-		       [p (begin (write `(,label MSG ,p))
-				 (newline)
-				 (flush-output)
-				 '())]))))

marketplace/test-struct-map-typed.rkt

@@ -1,12 +0,0 @@
-#lang typed/racket/base
-
-(require typed/rackunit)
-
-(require/typed "struct-map.rkt"
-	       [struct-map ((Any -> Any) Any -> Any)])
-(require/typed "test-struct-map.rkt"
-	       [#:struct foo ([bar : Integer]
-			      [zot : Integer])])
-
-(check-equal? (struct-map (lambda (x) (if (equal? x 123) 999 888)) (foo 123 234))
-	      (foo 999 234))

marketplace/tr-struct-copy.rkt

@@ -1,166 +0,0 @@
-#lang racket/base
-;; Revolting hacked-on struct-copy using unhygienic-identifier=?
-;; instead of free-identifier=? to compare accessor names, to get
-;; around the contracting of accessors exported from TR modules.
-;;
-;; Workaround for PR13149.
-
-(require (for-syntax racket/base racket/private/struct-info))
-
-(provide tr-struct-copy)
-
-(define-for-syntax (unhygienic-identifier=? a b)
-  (eq? (syntax->datum a)
-       (syntax->datum b)))
-
-(define-syntax (tr-struct-copy stx)
-  (if (not (eq? (syntax-local-context) 'expression))
-      (quasisyntax/loc stx (#%expression #,stx))
-      (syntax-case stx ()
-	[(form-name info struct-expr field+val ...)
-	 (let ([ans (syntax->list  #'(field+val ...))])
-	   ;; Check syntax:
-	   (unless (identifier? #'info)
-	     (raise-syntax-error #f "not an identifier for structure type" stx #'info))
-	   (for-each (lambda (an)
-		       (syntax-case an ()
-			 [(field val)
-			  (unless (identifier? #'field)
-			    (raise-syntax-error #f 
-						"not an identifier for field name" 
-						stx
-						#'field))]
-			 [(field #:parent p val)
-			  (unless (identifier? #'field)
-			    (raise-syntax-error #f 
-						"not an identifier for field name" 
-						stx
-						#'field))
-			  (unless (identifier? #'p)
-			    (raise-syntax-error #f 
-						"not an identifier for parent struct name" 
-						stx
-						#'field))]
-			 [_
-			  (raise-syntax-error #f
-					      (string-append
-					       "bad syntax;\n"
-					       " expected a field update of the form (<field-id> <expr>)\n"
-					       " or (<field-id> #:parent <parent-id> <expr>)")
-					      stx
-					      an)]))
-		     ans)
-	   (let-values ([(construct pred accessors parent)
-			 (let ([v (syntax-local-value #'info (lambda () #f))])
-			   (unless (struct-info? v)
-			     (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
-			   (let ([v (extract-struct-info v)])
-			     (values (cadr v)
-				     (caddr v)
-				     (cadddr v)
-				     (list-ref v 5))))])
-               
-	     (let* ([ensure-really-parent
-		     (λ (id)
-			(let loop ([parent parent])
-			  (cond
-			   [(eq? parent #t)
-			    (raise-syntax-error #f "identifier not bound to a parent struct" stx id)]
-			   [(not parent)
-			    (raise-syntax-error #f "parent struct information not known" stx id)]
-			   [(free-identifier=? id parent) (void)]
-			   [else
-			    (let ([v (syntax-local-value parent (lambda () #f))])
-			      (unless (struct-info? v)
-				(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
-			      (let ([v (extract-struct-info v)])
-				(loop (list-ref v 5))))])))]
-		    [new-fields
-		     (map (lambda (an)
-			    (syntax-case an ()
-			      [(field expr)
-			       (list (datum->syntax #'field
-						    (string->symbol
-						     (format "~a-~a"
-							     (syntax-e #'info)
-							     (syntax-e #'field)))
-						    #'field)
-				     #'expr
-				     (car (generate-temporaries (list #'field))))]
-			      [(field #:parent id expr)
-			       (begin
-				 (ensure-really-parent #'id)
-				 (list (datum->syntax #'field
-						      (string->symbol
-						       (format "~a-~a"
-							       (syntax-e #'id)
-							       (syntax-e #'field)))
-						      #'field)
-				       #'expr
-				       (car (generate-temporaries (list #'field)))))]))
-			  ans)]
-                      
-		    ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
-		    [new-binding-for 
-		     (lambda (f)
-		       (ormap (lambda (new-field)
-				(and (unhygienic-identifier=? (car new-field) f)
-				     (caddr new-field)))
-			      new-fields))])
-                 
-	       (unless construct
-		 (raise-syntax-error #f
-				     "constructor not statically known for structure type"
-				     stx
-				     #'info))
-	       (unless pred
-		 (raise-syntax-error #f
-				     "predicate not statically known for structure type"
-				     stx
-				     #'info))
-	       (unless (andmap values accessors)
-		 (raise-syntax-error #f
-				     "not all accessors are statically known for structure type"
-				     stx
-				     #'info))
-                 
-                 
-	       (let ([dests
-		      (map (lambda (new-field)
-			     (or (ormap (lambda (f2)
-					  (and f2
-					       (unhygienic-identifier=? (car new-field) f2)
-					       f2))
-					accessors)
-				 (raise-syntax-error #f 
-						     "accessor name not associated with the given structure type" 
-						     stx
-						     (car new-field))))
-			   new-fields)])
-		 ;; Check for duplicates using dests, not as, because mod=? as might not be id=?
-		 (let ((dupe (check-duplicate-identifier dests)))
-		   (when dupe 
-		     (raise-syntax-error #f 
-					 "duplicate field assignment" 
-					 stx 
-					 ;; Map back to an original field:
-					 (ormap (lambda (nf)
-						  (and nf
-						       (unhygienic-identifier=? dupe (car nf))
-						       (car nf)))
-						(reverse new-fields)))))
-                   
-		 ;; the actual result
-		 #`(let ((the-struct struct-expr))
-		     (if (#,pred the-struct)
-			 (let #,(map (lambda (new-field)
-				       #`[#,(caddr new-field) #,(cadr new-field)])
-				     new-fields)
-			   (#,construct
-			    #,@(map 
-				(lambda (field) (or (new-binding-for field) 
-						    #`(#,field the-struct)))
-				(reverse accessors))))
-			 (raise-argument-error 'form-name 
-					       #,(format "~a?" (syntax-e #'info))
-					       the-struct)))))))])))

marketplace/types.rkt

@@ -1,119 +0,0 @@
-#lang typed/racket/base
-
-(require "quasiqueue.rkt")
-
-(require/typed "opaque-any.rkt"
-	       ;; Various opaque "Any"s
-	       [opaque Topic topic?]
-	       [opaque PreEID pre-eid?]
-	       [opaque Reason reason?])
-
-(provide (all-defined-out)
-	 (all-from-out "quasiqueue.rkt"))
-
-;; This module uses different terminology to os2.rkt. From the paper:
-;; "A role generalizes traditional notions of advertisement and
-;; subscription by combining a topic of conversation with a direction:
-;; either publisher or subscriber. An endpoint combines a role with
-;; handlers for events relating to the conversation"
-
-(define-type Orientation (U 'publisher 'subscriber))
-
-(struct: role ([orientation : Orientation]
-	       [topic : Topic]
-	       [interest-type : InterestType])
-	 #:transparent)
-(define-type Role role)
-
-(define-type Message Topic) ;; Cheesy.
-
-(define-type InterestType (U 'participant 'observer 'everything))
-
-(define-type (Handler State) (TrapK EndpointEvent State))
-
-(define-type (InterruptK State) (State -> (Transition State)))
-(define-type (TrapK Event State) (Event -> (InterruptK State)))
-
-(define-type EndpointEvent (U PresenceEvent
-			      AbsenceEvent
-			      MessageEvent))
-
-(struct: presence-event ([role : Role]) #:transparent)
-(struct: absence-event ([role : Role] [reason : Reason]) #:transparent)
-(struct: message-event ([role : Role] [message : Message]) #:transparent)
-(define-type PresenceEvent presence-event)
-(define-type AbsenceEvent absence-event)
-(define-type MessageEvent message-event)
-
-(struct: (State)
-	 transition ([state : State]
-		     [actions : (ActionTree State)])
-	 #:transparent)
-(define-type (Transition State) (transition State))
-
-(define-type (ActionTree State) (Constreeof (Action State)))
-
-;; Existential quantification over State
-(define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result))
-
-;; Specification of a new process
-(struct: process-spec ([boot : (PID -> CoTransition)])
-	 #:transparent)
-(define-type ProcessSpec process-spec)
-
-(define-type (PreAction State) (U (add-endpoint State)
-				  delete-endpoint
-				  send-message
-				  (spawn State)
-				  quit))
-
-(struct: (State)
-	 add-endpoint ([pre-eid : PreEID]
-		       [role : Role]
-		       [handler : (Handler State)])
-	 #:transparent)
-(define-type (AddEndpoint State) (add-endpoint State))
-
-(struct: delete-endpoint ([pre-eid : PreEID]
-			  [reason : Reason])
-	 #:transparent)
-(define-type DeleteEndpoint delete-endpoint)
-
-(struct: send-message ([body : Message]
-		       [orientation : Orientation])
-	 #:transparent)
-(define-type SendMessage send-message)
-
-(struct: (State)
-	 spawn ([spec : process-spec]
-		[k : (Option (PID -> (InterruptK State)))]
-		[debug-name : Any])
-	 #:transparent)
-(define-type (Spawn State) (spawn State))
-
-(struct: quit ([pid : (Option PID)] ;; #f = suicide
-	       [reason : Reason])
-	 #:transparent)
-(define-type Quit quit)
-
-(define-type (Action State) (U (PreAction State)
-			       (yield State)
-			       (at-meta-level State)))
-
-(struct: (State)
-	 yield ([k : (InterruptK State)])
-	 #:transparent)
-(define-type (Yield State) (yield State))
-
-(struct: (State)
-	 at-meta-level ([preaction : (PreAction State)])
-	 #:transparent)
-(define-type (AtMetaLevel State) (at-meta-level State))
-
-(define-type PID Number)
-
-;;; Local Variables:
-;;; eval: (put 'transition 'scheme-indent-function 1)
-;;; eval: (put 'transition: 'scheme-indent-function 3)
-;;; eval: (put 'transition/no-state 'scheme-indent-function 0)
-;;; End:

marketplace/vm.rkt

@@ -1,135 +0,0 @@
-#lang typed/racket/base
-
-(require racket/match)
-(require "types.rkt")
-(require "roles.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
-
-(provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161)
-	 vm-next-process-id
-	 vm ;; really just want to export the type here, not the ctor
-	 vm?
-
-	 (struct-out process)
-	 (struct-out endpoint)
-	 (struct-out eid)
-	 Process
-	 CoProcess
-	 mkProcess
-	 unwrap-process
-
-	 make-vm
-	 inject-process
-	 extract-process
-	 always-false
-	 reset-pending-actions
-	 process-map
-	 endpoint-fold)
-
-(struct: vm ([processes : (HashTable PID Process)]
-	     [next-process-id : PID])
-	 #:transparent)
-
-(struct: (State)
-	 process ([debug-name : Any]
-		  [pid : PID]
-		  [state : State]
-		  [spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm
-		  [endpoints : (HashTable PreEID (endpoint State))]
-		  [meta-endpoints : (HashTable PreEID (endpoint State))]
-		  [pending-actions : (QuasiQueue (Action State))])
-	 #:transparent)
-
-(struct: (State)
-	 endpoint ([id : eid]
-		   [role : role]
-		   [handler : (Handler State)])
-	 #:transparent)
-
-(struct: eid ([pid : PID]
-	      [pre-eid : PreEID])
-	 #:transparent)
-
-(define-type Process		(All (R) (CoProcess R) -> R))
-(define-type (CoProcess R)	(All (State) (process State) -> R))
-
-(: mkProcess : (All (State) ((CoProcess Process) State)))
-;; A kind of identity function, taking the components of a process to
-;; a process.
-(define (mkProcess p)
-  (lambda (k) ((inst k State) p)))
-
-(: Process-pid : Process -> PID)
-(define (Process-pid wp) ((inst wp PID) process-pid))
-
-;; Unwraps a process. Result is the type of the result of the
-;; expression; State is a type variable to be bound to the process's
-;; private state type. p is to be bound to the unwrapped process; wp
-;; is the expression producing the wrapped process. body... are the
-;; forms computing a value of type Result.
-(define-syntax-rule (unwrap-process State Result (p wp) body ...)
-  (let ()
-    (: coproc : (All (State) (process State) -> Result))
-    (define (coproc p)
-      body ...)
-    ((inst wp Result) coproc)))
-
-;;---------------------------------------------------------------------------
-
-(: make-vm : process-spec -> vm)
-(define (make-vm boot)
-  (define primordial (mkProcess ((inst process Void)
-				 '#:primordial
-				 -1
-				 (void)
-				 (list)
-				 #hash()
-				 #hash()
-				 (quasiqueue ((inst spawn Void) boot #f '#:boot-process)))))
-  (vm (hash-set (ann #hash() (HashTable PID Process))
-		(Process-pid primordial)
-		primordial)
-      0))
-
-(: inject-process : vm Process -> vm)
-(define (inject-process state wp)
-  (struct-copy vm state [processes (hash-set (vm-processes state) (Process-pid wp) wp)]))
-
-(: always-false : -> False)
-(define (always-false) #f)
-
-(: extract-process : vm PID -> (values vm (Option Process)))
-(define (extract-process state pid)
-  (define wp (hash-ref (vm-processes state) pid always-false))
-  (values (if wp
-	      (struct-copy vm state [processes (hash-remove (vm-processes state) pid)])
-	      state)
-	  wp))
-
-(: reset-pending-actions : (All (State) (process State) -> (process State)))
-(define (reset-pending-actions p)
-  (struct-copy process p [pending-actions ((inst empty-quasiqueue (Action State)))]))
-
-(: process-map : (All (State) (process State) -> (process State)) vm -> vm)
-(define (process-map f state)
-  (for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))])
-    (let-values (((state wp) (extract-process state pid)))
-      (if (not wp)
-	  state
-	  (unwrap-process State vm (p wp)
-	    (inject-process state (mkProcess (f p))))))))
-
-(: endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A))
-(define (endpoint-fold f seed state)
-  (for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))])
-    (let-values (((state wp) (extract-process state pid)))
-      (if (not wp)
-	  seed
-	  (unwrap-process State A (p wp)
-	    (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))])
-	      (define ep (hash-ref (process-endpoints p) pre-eid))
-	      ((inst f State) p ep seed)))))))
-
-;;; Local Variables:
-;;; eval: (put 'unwrap-process 'scheme-indent-function 3)
-;;; End:

nested.rkt

@@ -1,18 +1,17 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "actions.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide make-nested-vm)
 
-(: make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State)))
+;; make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))
 (define (make-nested-vm make-boot debug-name)
   (spawn (process-spec (lambda (nested-vm-pid)
-			 (lambda (k) ((inst k vm) (run-vm (make-vm (make-boot nested-vm-pid)))))))
+			 (lambda (k) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
 	 #f
 	 debug-name))
 

process.rkt

@@ -1,11 +1,11 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
+(require "structs.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log-typed.rkt")
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
+(require "log.rkt")
+(require "quasiqueue.rkt")
 
 (provide send-to-user
 	 send-to-user*
@@ -18,7 +18,7 @@
   (send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr))
 
 (define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr)
-  (with-handlers ([exn:fail? (lambda: ([e : Reason])
+  (with-handlers ([exn:fail? (lambda (e)
 			       (if (exn? e)
 				   (marketplace-log 'error "Process ~v(~v):~n~a~n"
 						    debug-name pid (exn-message e))
@@ -30,44 +30,37 @@
     (marketplace-log 'debug "Leaving  process ~v(~v)" debug-name pid)
     result))
 
-(: action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State))))
+;; action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))
+;; TODO: simplify
 (define (action-tree->quasiqueue t)
-  (let loop ((#{revacc : (QuasiQueue (Action State))} '()) (t t))
-    ;; 1. Tried match with (define-predicate action? Action).
-    ;;    Failed because of parametric function contracts.
-    ;; 2. Tried flipping the order or clauses in the match to
-    ;;    avoid the use of (action?), trying to pull out the
-    ;;    false/nil/void leaving only, by exclusion, the
-    ;;    Action. Failed, complaining that it didn't know the
-    ;;    type in the third, default, branch.
-    ;; 3. Just like 2, but with cond. This worked!
+  (let loop ((revacc '()) (t t))
     (cond
      [(pair? t) (loop (loop revacc (car t)) (cdr t))]
      [(or (null? t) (eq? t #f) (void? t)) revacc]
      [else (cons t revacc)])))
 
 ;; Split out to provide a syntactic location to define State in
-(: quit-interruptk : Reason -> (All (State) State -> (Transition State)))
+;; quit-interruptk : Reason -> (All (State) State -> (Transition State))
 (define ((quit-interruptk e) old-process-state)
   (transition old-process-state (quit #f e)))
 
-(: run-ready : (All (State) (process State) (InterruptK State) -> (process State)))
+;; run-ready : (All (State) (process State) (InterruptK State) -> (process State))
 (define (run-ready p interruptk)
   (define old-state (process-state p))
   (match-define (transition new-state actions)
-    (send-to-user p (e) (transition old-state (ann (quit #f e) (Action State)))
+    (send-to-user p (e) (transition old-state (quit #f e))
       (interruptk old-state)))
   (struct-copy process p
 	       [state new-state]
 	       [pending-actions (quasiqueue-append (process-pending-actions p)
 						   (action-tree->quasiqueue actions))]))
 
-(: notify-route-change-self : (All (SNew)
-				   (process SNew)
-				   (endpoint SNew)
-				   (Role -> EndpointEvent)
-				   ->
-				   (process SNew)))
+;; notify-route-change-self : (All (SNew)
+;; 				   (process SNew)
+;; 				   (endpoint SNew)
+;; 				   (Role -> EndpointEvent)
+;; 				   ->
+;; 				   (process SNew))
 (define (notify-route-change-self pn en flow->notification)
   (define endpointso (process-endpoints pn))
   (for/fold ([pn pn]) ([eido (in-hash-keys endpointso)])
@@ -86,13 +79,13 @@
 				      flow->notification))]
      [else pn])))
 
-(: notify-route-change-process : (All (SOld SNew)
-				      (process SOld)
-				      (process SNew)
-				      (endpoint SNew)
-				      (Role -> EndpointEvent)
-				      -> (values (process SOld)
-						 (process SNew))))
+;; notify-route-change-process : (All (SOld SNew)
+;; 				      (process SOld)
+;; 				      (process SNew)
+;; 				      (endpoint SNew)
+;; 				      (Role -> EndpointEvent)
+;; 				      -> (values (process SOld)
+;; 						 (process SNew)))
 (define (notify-route-change-process po pn en flow->notification)
   (define endpointso (process-endpoints po))
   (for/fold ([po po]
@@ -109,39 +102,37 @@
      [else
       (values po pn)])))
 
-(: invoke-handler-if-visible : (All (State)
-				    (process State)
-				    (endpoint State)
-				    Role
-				    (Role -> EndpointEvent)
-				    ->
-				    (process State)))
+;; invoke-handler-if-visible : (All (State)
+;; 				    (process State)
+;; 				    (endpoint State)
+;; 				    Role
+;; 				    (Role -> EndpointEvent)
+;; 				    ->
+;; 				    (process State))
 (define (invoke-handler-if-visible p ep flow flow->notification)
   (if (flow-visible? (endpoint-role ep) flow)
       (run-ready p (send-to-user p (e) (quit-interruptk e)
 		     ((endpoint-handler ep) (flow->notification flow))))
       p))
 
-(: notify-route-change-vm : (All (SNew)
-				 (process SNew)
-				 (endpoint SNew)
-				 (Role -> EndpointEvent)
-				 vm
-				 -> (values (process SNew)
-					    vm)))
+;; notify-route-change-vm : (All (SNew)
+;; 				 (process SNew)
+;; 				 (endpoint SNew)
+;; 				 (Role -> EndpointEvent)
+;; 				 vm
+;; 				 -> (values (process SNew)
+;; 					    vm))
 (define (notify-route-change-vm pn en flow->notification state)
   (define old-processes (vm-processes state))
   (define-values (final-pn new-processes)
-    (for/fold: : (values (process SNew)
-			 (HashTable PID Process))
-        ([pn (notify-route-change-self pn en flow->notification)]
-	 [new-processes (ann #hash() (HashTable PID Process))])
+    (for/fold ([pn (notify-route-change-self pn en flow->notification)]
+	       [new-processes #hash()])
 	([pid (in-hash-keys old-processes)])
       (define wp (hash-ref old-processes pid))
       (apply values
-	     (unwrap-process SOld (List (process SNew) (HashTable PID Process)) (po wp)
+	     (let ((po wp))
 	       (let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
-		 (list pn (hash-set new-processes pid (mkProcess po))))))))
+		 (list pn (hash-set new-processes pid po)))))))
   (values final-pn
 	  (struct-copy vm state [processes new-processes])))
 

quasiqueue.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+
+(provide empty-quasiqueue
+	 quasiqueue-empty?
+	 quasiqueue-append-list
+	 quasiqueue-append
+	 quasiqueue
+	 list->quasiqueue
+	 quasiqueue->list
+	 quasiqueue->cons-tree)
+
+;; A QuasiQueue<X> is a list of Xs in *reversed* order.
+;; (define-type (QuasiQueue X) (Listof X))
+
+;; (define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null)))
+
+;; empty-quasiqueue : (All (X) -> (QuasiQueue X))
+(define (empty-quasiqueue) '())
+
+;; quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean)
+(define (quasiqueue-empty? q) (null? q))
+
+;; quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X))
+(define (quasiqueue-append-list q xs)
+  (append (reverse xs) q))
+
+;; quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X))
+(define (quasiqueue-append q1 q2)
+  (append q2 q1))
+
+;; quasiqueue : (All (X) X * -> (QuasiQueue X))
+(define (quasiqueue . xs)
+  (reverse xs))
+
+;; list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X))
+(define (list->quasiqueue xs)
+  (reverse xs))
+
+;; quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X))
+(define (quasiqueue->list q)
+  (reverse q))
+
+;; quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X))
+(define (quasiqueue->cons-tree q)
+  (reverse q))

roles.rkt

@@ -1,14 +1,9 @@
-#lang typed/racket/base
+#lang racket/base
 
 (require racket/match)
-(require "types.rkt")
-(require "log-typed.rkt")
-(require/typed "unify.rkt"
-	       [wild (case-> (-> Topic) (Symbol -> Topic))]
-	       [mgu-canonical (Topic Topic -> Topic)]
-	       [freshen (Topic -> Topic)]
-	       [specialization? (Topic Topic -> Boolean)])
-(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
+(require "structs.rkt")
+(require "log.rkt")
+(require "unify.rkt")
 
 (provide co-orientations
 	 co-roles
@@ -18,34 +13,34 @@
 	 role-intersection
 	 flow-visible?)
 
-(: co-orientations : Orientation -> (Listof Orientation))
+;; co-orientations : Orientation -> (Listof Orientation)
 (define (co-orientations o)
   (match o
     ['publisher '(subscriber)]
     ['subscriber '(publisher)]))
 
-(: co-roles : Role -> (Listof Role))
+;; co-roles : Role -> (Listof Role)
 (define (co-roles r)
-  (for/list: ([co-orientation : Orientation (co-orientations (role-orientation r))])
+  (for/list ([co-orientation (co-orientations (role-orientation r))])
     (struct-copy role r [orientation co-orientation])))
 
-(: refine-role : Role Topic -> Role)
+;; refine-role : Role Topic -> Role
 (define (refine-role remote-role new-topic)
   (struct-copy role remote-role [topic new-topic]))
 
-(: roles-equal? : Role Role -> Boolean)
+;; roles-equal? : Role Role -> Boolean
 (define (roles-equal? ta tb)
   (and (equal? (role-orientation ta) (role-orientation tb))
        (equal? (role-interest-type ta) (role-interest-type tb))
        (specialization? (role-topic ta) (role-topic tb))
        (specialization? (role-topic tb) (role-topic ta))))
 
-(: orientations-intersect? : Orientation Orientation -> Boolean)
+;; orientations-intersect? : Orientation Orientation -> Boolean
 (define (orientations-intersect? l r)
   (and (memq l (co-orientations r)) #t))
 
 ;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean?
-(: role-intersection : Role Role -> (Option Topic))
+;; role-intersection : Role Role -> (Option Topic)
 (define (role-intersection left right)
   (define result
     (and (orientations-intersect? (role-orientation left) (role-orientation right))
@@ -72,7 +67,7 @@
 ;; | 'everything  | 'everything  | yes                    |
 ;; |--------------+--------------+------------------------|
 ;;
-(: flow-visible? : Role Role -> Boolean)
+;; flow-visible? : Role Role -> Boolean
 (define (flow-visible? local-role remote-role)
   (or (eq? (role-interest-type remote-role) 'participant)
       (eq? (role-interest-type local-role) 'everything)))

scribblings/Makefile

@@ -1,7 +1,12 @@
 all: out
 
 pages:
-	git clone -b gh-pages ../.. pages
+	@(git branch -v | grep -q gh-pages || (echo local gh-pages branch missing; false))
+	@echo
+	@git branch -av | grep gh-pages
+	@echo
+	@(echo 'Is the branch up to date? Press enter to continue.'; read dummy)
+	git clone -b gh-pages .. pages
 
 publish: out pages
 	rm -rf pages/*

scribblings/concepts.scrbl

@@ -82,8 +82,9 @@ actions the process wishes to perform. See @secref{Actions} for the
 possible actions a process can take.
 
 Note that the result of an event handler function is actually a
-@racket[Transition] structure; the actual Typed Racket type of event
-handlers is @racket[TrapK], defined in @secref{handler-functions}.
+@racket[transition] structure containing a new state and a sequence of
+actions, rather than the explicit pair shown in the approximate type
+above. See @secref{handler-functions} for more on handler functions.
 
 @section{What is a VM?}
 

scribblings/drivers.scrbl

@@ -13,7 +13,7 @@
 
 @defproc[(event-relay [self-id Symbol]) Spawn]{
 
-Lets processes in some @racket[nested-vm] interact with the outside
+Lets processes in some nested VM interact with the outside
 world using @racket[ground-vm]-level event-based subscriptions.
 
 Returns a @racket[spawn] which starts an event-relay process with
@@ -34,10 +34,9 @@ the subscription at the meta-level as well.
 
 @defmodule[marketplace/drivers/tcp-bare]{
 
-This module is only available for use by untyped Racket processes. It
-is included by default in programs using @tt{#lang marketplace}; see
-@secref{hashlang-variations} for information on other language
-variants.
+This module is included by default in programs using @tt{#lang
+marketplace}; see @secref{hashlang-variations} for information on
+other language variants.
 
 @defproc[(tcp-driver) Spawn]{
 
@@ -57,9 +56,9 @@ A pre-made @racket[spawn] action equivalent to @racket[(tcp-driver)].
 
 @subsection{TCP channels}
 
-@defstruct*[tcp-channel ([source TcpAddress]
-			 [destination TcpAddress]
-			 [subpacket TcpSubPacket]) #:prefab]{
+@defstruct*[tcp-channel ([source (or/c tcp-address? tcp-handle? tcp-listener?)]
+			 [destination (or/c tcp-address? tcp-handle? tcp-listener?)]
+			 [subpacket (or/c eof-object? bytes?)]) #:prefab]{
 
 A TCP channel represents a section of a unidirectional TCP flow
 appearing on our local "subnet" of the full TCP network, complete with
@@ -67,10 +66,6 @@ source, destination and subpacket. Each TCP connection has two such
 flows: one inbound (remote-to-local) bytestream, and one outbound
 (local-to-remote) bytestream.
 
-}
-
-@deftype[TcpSubPacket (or/c eof-object? bytes?)]{
-
 Packets carried by @racket[tcp-channel] structures are either
 end-of-file objects or raw binary data represented as Racket byte
 vectors.
@@ -79,8 +74,6 @@ vectors.
 
 @subsection{TCP addresses}
 
-@deftype[TcpAddress (or/c tcp-address? tcp-handle? tcp-listener?)]{
-
 A TCP address describes one end of a TCP connection. It can be either
 
 @itemlist[
@@ -89,8 +82,6 @@ A TCP address describes one end of a TCP connection. It can be either
   @item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
 ]
 
-}
-
 @defstruct*[tcp-address ([host string?]
 			 [port (integer-in 0 65535)]) #:prefab]{
 
@@ -109,7 +100,7 @@ a local name for whichever underlying port number ends up being used.
 The @racket[id] must be chosen carefully: it is scoped to the local
 VM, i.e. shared between processes in that VM, so processes must make
 sure not to accidentally clash in handle ID selection. They are also
-used in TcpChannel to mean a specific @emph{instance} of a TCP
+used in @racket[tcp-channel] to mean a specific @emph{instance} of a TCP
 connection, so if you are likely to want to reconnect individual
 flows, use different values for @racket[id].
 
@@ -130,14 +121,15 @@ Choose a @racket[tcp-handle], and then create endpoints as follows:
 (let ((local (tcp-handle 'some-unique-value))
       (remote (tcp-address "the.remote.host.example.com" 5999)))
   (transition/no-state
-   (endpoint #:publisher (tcp-channel local remote ?))
-   (endpoint #:subscriber (tcp-channel remote local ?)
-	     [(tcp-channel _ _ (? eof-object?))
-	      (code:comment "Handle a received end-of-file object")
-	      (transition ...)]
-	     [(tcp-channel _ _ (? bytes? data))
-	      (code:comment "Handle received data")
-	      (transition ...)])))
+   (publisher (tcp-channel local remote ?))
+   (subscriber (tcp-channel remote local ?)
+     (on-message
+      [(tcp-channel _ _ (? eof-object?))
+       (code:comment "Handle a received end-of-file object")
+       (transition ...)]
+      [(tcp-channel _ _ (? bytes? data))
+       (code:comment "Handle received data")
+       (transition ...)]))))
 ]
 
 The TCP driver will automatically create an outbound connection in
@@ -153,18 +145,18 @@ Choose a port number, and then create an @emph{observer} endpoint as
 follows:
 
 @racketblock[
-(endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?) #:observer
-	  #:conversation (tcp-channel them us _)
-	  #:on-presence (spawn #:child (chat-session them us)))
+(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+  (match-conversation (tcp-channel them us _)
+    (on-presence (spawn (chat-session them us)))))
 ]
 
-The use of @racket[#:observer] here indicates that this endpoint isn't
+The use of @racket[observe-publishers] here indicates that this endpoint isn't
 actually interested in exchanging any TCP data; instead, it is
-monitoring demand for such exchanges. The TCP driver uses a rare
-@racket[#:everything] endpoint to monitor the presence of
-@racket[#:observer]s, and creates listening TCP server sockets in
+monitoring demand for such exchanges. The TCP driver uses the unusual
+@racket['everything] @racket[InterestType] to monitor the presence of
+@racket['observer]s, and creates listening TCP server sockets in
 response. When a connection comes in, the TCP driver spawns a manager
-process which offers regular @racket[#:participant] endpoints for
+process which offers regular @racket['participant] endpoints for
 communicating on the newly-arrived socket.
 
 To illustrate the code for handling a newly-arrived connection,
@@ -172,11 +164,11 @@ To illustrate the code for handling a newly-arrived connection,
 @racketblock[
 (define (chat-session them us)
   (transition/no-state
-   (endpoint #:subscriber (tcp-channel them us ?)
-	     #:on-absence (quit)
-	     [(tcp-channel _ _ (? bytes? data))
-	      (code:comment "Handle incoming data")
-	      (transition ...)])))
+   (subscriber (tcp-channel them us ?)
+     (on-absence (quit))
+     (on-message [(tcp-channel _ _ (? bytes? data))
+		  (code:comment "Handle incoming data")
+		  (transition ...)]))))
 ]
 
 @subsection{Receiving data}
@@ -202,14 +194,14 @@ where, as for receiving data, the @racket[subpacket] is either
 Not yet documented.
 }
 
-@section{timer (typed and untyped)}
+@section{timer}
 
 For examples of the use of the timer driver, see uses of
 @racket[set-timer] and @racket[timer-expired] in
 @hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/network-query.rkt"]{the
 Marketplace-based DNS resolver}.
 
-@section{udp (typed and untyped)}
+@section{udp}
 
 For examples of the use of the UDP driver, see uses of
 @racket[udp-packet] etc. in

scribblings/examples.scrbl

@@ -0,0 +1,139 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title{Examples}
+
+@section[#:tag "echo-server-example"]{TCP echo server}
+
+Here is a complete Marketplace program:
+
+@#reader scribble/comment-reader (racketmod #:file "examples/echo-paper.rkt" marketplace
+
+(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+  (match-conversation (tcp-channel from to _)
+    (on-presence (spawn (echoer from to)))))
+
+(define (echoer from to)
+  (transition stateless
+    (publisher (tcp-channel to from ?))
+    (subscriber (tcp-channel from to ?)
+      (on-absence (quit))
+      (on-message
+       [(tcp-channel _ _ data)
+        (send-message (tcp-channel to from data))]))))
+)
+
+The top-level @racket[observe-publishers] monitors TCP connections
+arriving on port 5999 and @racket[spawn]s a fresh process in response
+to each with the help of the auxiliary @racket[echoer] function. The
+topic of conversation associated with the each new connection is
+parsed (with @racket[match-conversation]) to name the remote
+(@racket[from]) and local (@racket[to]) TCP addresses, which are
+passed to @racket[echoer] to create the initial state and actions for
+the corresponding process. In this case, the process is stateless,
+indicated by the special constant @racket[stateless].
+
+Each connection's process watches for incoming data, using
+@racket[from] and @racket[to] to configure a @racket[subscriber]. It
+also declares its intent to produce outbound TCP data, using
+@racket[publisher]. When data arrives, it is echoed back to the remote
+peer using the @racket[send-message] operation. Absence notifications
+signal disconnection; when the remote peer closes the TCP connection,
+the @racket[on-absence] handler issues a @racket[quit] action, which
+terminates the connection's process.
+
+@section[#:tag "chat-server-example"]{TCP chat server}
+
+@#reader scribble/comment-reader (racketmod #:file "examples/chat-paper.rkt" marketplace
+
+(spawn-vm
+ (at-meta-level
+  (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+    (match-conversation (tcp-channel them us _)
+      (on-presence (spawn (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
+   (at-meta-level
+    (subscriber (tcp-channel them us ?)
+      (on-absence (quit))
+      (on-message
+       [(tcp-channel _ _ (? bytes? text))
+        (send-message `(,user says ,text))])))
+   (publisher `(,user says ,?))))
+
+(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
+    (publisher (tcp-channel us them ?)))
+   (subscriber `(,? 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)])))))
+)
+
+@section[#:tag "chat-client-example"]{TCP chat client}
+
+@#reader scribble/comment-reader (racketmod #:file "examples/chat-client.rkt" marketplace
+(require racket/port)
+
+;; 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.
+(name-process 'console-output-driver
+  (spawn (transition/no-state
+           (subscriber (list 'console-output ?)
+             (on-message [(list 'console-output item)
+                          (printf "~a" item)
+                          (void)])))))
+
+(name-process 'console-input-driver
+  (spawn (transition/no-state
+           (name-endpoint 'input-relay
+             (publisher (list 'console-input ?)
+               (on-absence
+                (send-message (list 'console-output "Connection terminated.\n"))
+                (quit))))
+           (subscriber (cons (read-line-evt (current-input-port) 'any) ?)
+             (on-message
+              [(cons _ (? eof-object?))
+               (send-message (list 'console-output "Terminating on local EOF.\n"))
+               (delete-endpoint 'input-relay)]
+              [(cons _ (? string? line))
+               (send-message (list 'console-input line))])))))
+
+(name-process 'outbound-connection
+  (spawn (let ((local (tcp-handle 'outbound))
+               (remote (tcp-address "localhost" 5999)))
+           (transition/no-state
+             (subscriber (list 'console-input ?)
+               (on-absence (quit))
+               (on-message
+                [(list 'console-input line)
+                 (send-message (list 'console-output (format "> ~a \n" line)))
+                 (send-message (tcp-channel local remote (string-append line "\n")))]))
+             (publisher (tcp-channel local remote ?))
+             (subscriber (tcp-channel remote local ?)
+               (on-absence (quit))
+               (on-message
+                [(tcp-channel _ _ (? eof-object?))
+                 (quit)]
+                [(tcp-channel _ _ data)
+                 (send-message (list 'console-output (format "< ~a" data)))]))))))
+)

scribblings/highlevel.scrbl

@@ -2,15 +2,9 @@
 @require[racket/include]
 @include{prelude.inc}
 
-@require[(for-label (except-in marketplace/sugar-untyped transition/no-state)
-		    (only-in marketplace/drivers/tcp-bare tcp)
-		    (except-in marketplace/sugar-typed ?))]
-
 @title[#:tag "high-level-interface"]{High-level interface}
 
-@declare-exporting[#:use-sources (marketplace/sugar-values
-				  marketplace/sugar-untyped
-				  marketplace/sugar-typed)]
+@declare-exporting[#:use-sources (marketplace/sugar)]
 
 This high-level interface between a VM and a process is analogous to
 the @emph{C library interface} of a Unix-like operating system. The
@@ -21,9 +15,7 @@ interface} of a Unix-like operating system.
 
 @;{
 @defmodulelang*[(marketplace
-		 marketplace/flow-control
-		 marketplace/typed
-		 marketplace/typed/flow-control)]
+		 marketplace/flow-control)]
 }
 
 @defmodulelang[marketplace]
@@ -37,116 +29,86 @@ actions spawn application processes and nested VMs, which in turn
 subscribe to sources of events from the outside world.
 
 At present, there's just @tt{#lang marketplace}. In future, there will
-be a variation for Typed Racket, and languages providing greater
-support for flow control, responsibility transfer, and other
-networking concepts. For now, Typed Racket programs must be written as
-@tt{#lang typed/racket} programs using @racket[(require marketplace)]
-and @racket[ground-vm:] explicitly.
+be languages providing greater support for flow control,
+responsibility transfer, and other networking concepts.
 
 @;{
 @itemlist[
 
-  @item{@racket[marketplace] is for @emph{untyped} programs, and uses
+  @item{@racket[marketplace] is for ordinary Racket programs, and uses
   the @secref{tcp-bare} TCP driver;}
 
   @item{@racket[marketplace/flow-control] is like
   @racket[marketplace], but uses the flow-controlled @secref{tcp}
   driver;}
 
-  @item{@racket[marketplace/typed] is like @racket[marketplace], but
-  for @emph{typed} programs;}
-
-  @item{@racket[marketplace/typed/flow-control] is like
-  @racket[marketplace/flow-control], but for typed programs.}
-
 ]
 }
 
 @section{Using Marketplace as a library}
 
-@defmodule*[(marketplace/sugar-untyped
-	     marketplace/sugar-typed)
-	    #:use-sources (marketplace/sugar-values
-			   marketplace/sugar-untyped
-			   marketplace/sugar-typed)]
+@defmodule*[(marketplace/sugar)
+	    #:use-sources (marketplace/sugar)]
 
 Instead of using Racket's @tt{#lang} feature, ordinary Racket programs
 can use Marketplace features by requiring Marketplace modules
 directly.
 
-Such programs need to use @racket[ground-vm]/@racket[ground-vm:] to
+Such programs need to use @racket[ground-vm] to
 start the ground-level VM explicitly. They also need to explicitly
 start any drivers they need; for example, the file
 @filepath{examples/echo-plain.rkt} uses @racket[ground-vm] along with
 @racket[tcp] and an initial @racket[endpoint] action:
 
 @racketblock[
-(ground-vm
-  tcp
-  (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
-	    #:conversation (tcp-channel from to _)
-	    #:on-presence (spawn #:child (echoer from to))))
+(ground-vm tcp
+           (subscriber (tcp-channel ? (tcp-listener 5999) ?)
+             (match-conversation (tcp-channel from to _)
+               (on-presence (spawn (echoer from to))))))
 ]
 
-@deftogether[(
-@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)]
-@defform[(ground-vm: maybe-boot-pid-binding maybe-typed-initial-state initial-action ...)
+@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)
 	 #:grammar
 	 [(maybe-boot-pid-binding (code:line)
 	 			  (code:line #:boot-pid id))
 	  (maybe-initial-state (code:line)
 	  		       (code:line #:initial-state expr))
-	  (maybe-typed-initial-state (code:line)
-	  		       	     (code:line #:initial-state expr : type))
-	  (initial-action expr)]]
-)]{
+	  (initial-action expr)]]{
 
-Starts the ground VM, in untyped and typed programs, respectively. If
-@racket[#:boot-pid] is specified, the given identifier is bound within
-the form to the PID of the @emph{primordial process} that performs the
-initial actions. If @racket[#:initial-state] is specified (with a
-type, for @racket[ground-vm:]), it is used as the initial state for
-the primordial process; if it is not supplied, the primordial process
-is given @racket[(void)] as its initial state (and @racket[Void] as
-its state type).
+Starts the ground VM. If @racket[#:boot-pid] is specified, the given
+identifier is bound within the form to the PID of the @emph{primordial
+process} that performs the initial actions. If
+@racket[#:initial-state] is specified, it is used as the initial state
+for the primordial process; if it is not supplied, the primordial
+process is given @racket[(void)] as its initial state.
 
 }
 
 @section[#:tag "constructing-transitions"]{Constructing transitions}
 
 @declare-exporting[#:use-sources (marketplace
-				  marketplace/sugar-values
-				  marketplace/sugar-untyped
-				  marketplace/sugar-typed)]
+				  marketplace/sugar)]
 
 @deftogether[(
 @defform[(transition new-state action-tree ...)]
-@defform[(transition: new-state : State action-tree ...)]
 @defform[(transition/no-state action-tree ...)]
 )]{
 
-Each of these forms produces a @racket[Transition] structure. The
-first is for untyped code, the second for typed code (where the
-mandatory @racket[State] is the type of the transitioning process's
-private state), and the third for either.
+Each of these forms produces a @racket[transition] structure.
 
-Each @racket[action-tree] must be an @racket[(ActionTree State)].
-
-It's fine to include @emph{no} action-trees, in which case the
+Each @racket[action-tree] must be an @tech{action tree}.
+It's fine to include @emph{no} action trees, in which case the
 transition merely updates the state of the process without taking any
 actions.
 
-In the case of @racket[transition/no-state], the type @racket[Void]
-and value @racket[(void)] is used for the process state.
-@racket[transition/no-state] is useful for processes that are
-stateless other than the implicit state of their endpoints.
+In the case of @racket[transition/no-state], the value @racket[(void)]
+is used for the process state. @racket[transition/no-state] is useful
+for processes that are stateless other than the implicit state of
+their endpoints.
 
 }
 
-@deftogether[(
-@defstruct*[transition ([state State] [actions (ActionTree State)]) #:transparent]
-@deftype[(Transition State) (transition State)]
-)]{
+@defstruct*[transition ([state State] [actions action-tree?]) #:transparent]{
 
 A transition structure. The @racket[transition-state] field is the new
 private state the process will have after the transition is applied,
@@ -155,16 +117,23 @@ performed by the VM in order to apply the transition.
 
 }
 
-@deftogether[(
-@deftype[(ActionTree State) (Constreeof (Action State))]
-@deftype[(Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null))]
-)]{
+@defproc[(action-tree? [value any/c]) boolean?]{
 
-An action-tree is a @deftech{cons-tree} of @racket[Action]s. When
-performing actions, a VM will traverse an action-tree in left-to-right
-order.
+Predicate that recognises an @deftech{action tree}. An action tree is
+either
 
-@racket['()], @racket[(void)], and @racket[#f] may also be present in
+@itemlist[
+	  @item{@racket['()];}
+	  @item{@racket[#f];}
+	  @item{@racket[(void)];}
+	  @item{a pair of action trees; or}
+	  @item{an @tech{action}.}
+]
+
+When performing actions, a VM will traverse an action-tree in
+left-to-right order.
+
+@racket['()], @racket[(void)], and @racket[#f] may be present in
 action-trees: when the VM reaches such a value, it ignores it and
 continues with the next leaf in the tree.
 
@@ -206,10 +175,9 @@ at all" in a transition:
 
 }
 
-@defproc[(sequence-actions [initial-transition (Transition State)]
-			   [item (U (ActionTree State)
-				    (State -> (Transition State)))]
-			   ...) (Transition State)]{
+@defproc[(sequence-actions [initial-transition transition?]
+			   [item (or/c action-tree? (any/c -> transition?))]
+			   ...) transition?]{
 
 Returns a transition formed from the @racket[initial-transition]
 extended with new actions, possibly updating its carried state. Each
@@ -245,179 +213,139 @@ produces the equivalent of
 
 The primitive action that creates new endpoints is
 @racket[add-endpoint], but because endpoints are the most flexible and
-complex point of interaction between a process and its VM, a DSL,
-@racket[endpoint], streamlines endpoint setup.
+complex point of interaction between a process and its VM, a
+collection of macros helps streamline endpoint setup.
 
 @deftogether[(
-@defform[(endpoint orientation topic maybe-interest-type
-		   maybe-let-name
-		   maybe-name
-		   maybe-state-pattern
-		   maybe-on-presence
-		   maybe-on-absence
-		   maybe-role-patterns
-		   maybe-reason-pattern
-		   maybe-message-handlers)]
-@defform[#:literals (:)
-	 (endpoint: maybe-typed-state-pattern : State
-		    orientation topic maybe-interest-type
-		    maybe-let-name
-		    maybe-name
-		    maybe-on-presence
-		    maybe-on-absence
-		    maybe-role-patterns
-		    maybe-reason-pattern
-		    maybe-message-handlers)
-	 #:grammar
-	 [(maybe-typed-state-pattern (code:line)
-				     (code:line pattern))
-	  (orientation #:subscriber
-		       #:publisher)
-	  (topic expr)
-	  (maybe-interest-type (code:line)
-			       #:participant
-			       #:observer
-			       #:everything)
-	  (maybe-let-name (code:line)
-			  (code:line #:let-name identifier))
-	  (maybe-name (code:line)
-		      (code:line #:name expr))
-	  (maybe-state-pattern (code:line)
-			       (code:line #:state pattern))
-	  (maybe-on-presence (code:line)
-			     (code:line #:on-presence handler-expr))
-	  (maybe-on-absence (code:line)
-			    (code:line #:on-absence handler-expr))
-	  (maybe-role-patterns (code:line)
-			       (code:line #:role pattern)
-			       (code:line #:peer-orientation pattern
-					  #:conversation pattern
-					  #:peer-interest-type pattern))
-	  (maybe-reason-pattern (code:line)
-				(code:line #:reason pattern))
-	  (maybe-message-handlers (code:line)
-				  (code:line message-handler ...))
-	  (message-handler [pattern handler-expr])
-	  (handler-expr expr)]]
+@defform[(publisher topic handler ...)]
+@defform[(subscriber topic handler ...)]
+@defform[(observe-subscribers topic handler ...)]
+@defform[(observe-publishers topic handler ...)]
+@defform[(observe-subscribers/everything topic handler ...)]
+@defform[(observe-publishers/everything topic handler ...)]
+@defform[(build-endpoint pre-eid role handler ...)]
 )]{
 
-Almost everything is optional in an @racket[endpoint]. The only
-mandatory parts are the orientation and the topic. For
-@racket[endpoint:], the expected type of the process state must also
-be supplied.
+The many variations on the core
+@racket[build-endpoint] form exist to give
+good control over @racket[InterestType] in the endpoint under
+construction;
+see @secref{participating-vs-observing}.
+
+Almost everything is optional in an endpoint definition. The only
+mandatory part is the topic.
 
 For example, a minimal endpoint subscribing to all messages would be:
 
-@racketblock[(endpoint #:subscriber ?)]
-
-or in Typed Racket, for a process with @racket[Integer] as its process
-state type,
-
-@racketblock[(endpoint: : Integer #:subscriber ?)]
+@racketblock[(subscriber ?)]
 
 A minimal publishing endpoint would be:
 
-@racketblock[(endpoint #:publisher ?)
-	     (endpoint: : Integer #:publisher ?)]
+@racketblock[(publisher ?)]
 
 While topic patterns are ordinary Racket data with embedded @racket[?]
 wildcards (see @secref{messages-and-topics}), all the other patterns
-in an @racket[endpoint] are @racket[match]-patterns. In particular
+in an endpoint definition are @racket[match]-patterns. In particular
 note that @racket[?] is a wildcard in a topic pattern, while
 @racket[_] is a wildcard in a @racket[match]-pattern.
 
 @subsection{Receiving messages}
 
-Supply one or more @racket[message-handler] clauses to handle incoming
-message events (as distinct from presence- or absence-events).
+@defform[(on-message [pattern expr ...] ...)]{
+
+Supply an @racket[on-message] handler clause to an endpoint definition
+to handle incoming message events (as distinct from presence- or
+absence-events).
 
 The following endpoint @emph{subscribes} to all messages, but only
 @emph{handles} some of them:
 
-@racketblock[(endpoint #:subscriber ?
-		       ['ping (send-message 'pong)]
-		       ['hello (list (send-message 'goodbye)
-				     (quit))])]
+@racketblock[(subscriber ?
+	       (on-message
+		['ping (send-message 'pong)]
+		['hello (list (send-message 'goodbye)
+			      (quit))]))]
+
+}
+
+}
 
 @subsection{Action-only vs. State updates}
 
-If @racket[#:state] occurs in an @racket[endpoint], or the
-@racket[maybe-typed-state-pattern] occurs in an @racket[endpoint:],
-then all the @racket[handler-expr]s in that endpoint are expected to
-return @seclink["constructing-transitions"]{transition structures}.
+@defform[(match-state pattern handler ...)]{
 
-If not, however, the event handler expressions are expected to return
-plain @racket[ActionTree]s.
+If a group of handlers is wrapped in @racket[match-state], then all
+the wrapped handlers are expected to return
+@seclink["constructing-transitions"]{transition structures}.
 
-This way, simple endpoints that do not need to examine the process
+If not, however, the handler expressions are expected to return plain
+@tech{action tree}s.
+
+This way, simple handlers that do not need to examine the process
 state, and simply act in response to whichever event triggered them,
 can be written without the clutter of threading the process state
 value through the code.
 
 For example, a simple endpoint could be written either as
 
-@racketblock[(endpoint #:subscriber 'ping
-		       ['ping (send-message 'pong)])]
+@racketblock[(subscriber 'ping
+	       (on-message ['ping (send-message 'pong)]))]
 
 or, explicitly accessing the endpoint's process's state,
 
-@racketblock[(endpoint #:subscriber 'ping
-		       #:state old-state
-		       ['ping (transition old-state
-				(send-message 'pong))])]
+@racketblock[(subscriber 'ping
+	       (match-state old-state
+		 (on-message ['ping (transition old-state
+				      (send-message 'pong))])))]
 
-@subsection[#:tag "naming-endpoints"]{Naming endpoints}
-
-Endpoint names can be used to @seclink["updating-endpoints"]{update}
-or @seclink["deleting-endpoints"]{delete} endpoints.
-
-If @racket[#:name] is supplied, the given value is used as the name of
-the endpoint. If not, a fresh name is created. (At present,
-@racket[gensym] is used.)
-
-If @racket[#:let-name] is supplied, the given identifier is bound in
-the @racket[handler-expr]s to the name of the endpoint. If not, the
-name of the endpoint is inaccessible to the @racket[handler-expr]s.
+}
 
 @subsection{Handling presence and absence events}
 
+@deftogether[(
+@defform[(on-presence expr ...)]
+@defform[(on-absence expr ...)]
+)]{
+
 Other endpoints (in this or other processes) may have matching topics
 and complementary orientations to the current endpoint. When such
 endpoints come and go, presence and absence events are generated in
 the current endpoint.
 
 By default, no actions are taken on such events, but
-@racket[#:on-presence] and @racket[#:on-absence] override this
+@racket[on-presence] and @racket[on-absence] handlers override this
 behaviour.
 
 For example, say process A establishes the following endpoint:
 
-@racketblock[(endpoint #:subscriber 'ping
-		       #:on-presence (send-message 'pinger-arrived)
-		       #:on-absence  (send-message 'pinger-departed)
-		       ['ping (send-message 'pong)])]
+@racketblock[(subscriber 'ping
+	       (on-presence (send-message 'pinger-arrived))
+	       (on-absence  (send-message 'pinger-departed))
+	       (on-message ['ping (send-message 'pong)]))]
 
 Some time later, process B takes the following endpoint-establishing
 action:
 
-@racketblock[(endpoint #:publisher 'ping
-		       #:let-name ping-endpoint-name
-		       #:on-presence
-		       (list (endpoint #:subscriber 'pong
-				       #:let-name pong-waiter-name
-				       ['pong (list (delete-endpoint ping-endpoint-name)
-						    (delete-endpoint pong-waiter-name))])
-			     (send-message 'ping)))]
+@racketblock[(let-fresh (ping-endpoint-name pong-waiter-name)
+	       (name-endpoint ping-endpoint-name
+		 (publisher 'ping
+		   (on-presence
+		    (list (name-endpoint pong-waiter-name
+			    (subscriber 'pong
+			      (on-message
+			       ['pong (list (delete-endpoint ping-endpoint-name)
+					    (delete-endpoint pong-waiter-name))])))
+			  (send-message 'ping))))))]
 
 The sequence of events will be:
 
 @itemlist[
 
-  @item{Process A's @racket[#:on-presence] handler will run, and the
+  @item{Process A's @racket[on-presence] handler will run, and the
   @racket['pinger-arrived] message will be sent. At the same
   time,@note{In the current implementation, one happens before the
   other, but it is nondeterministic which is run first.} process B's
-  @racket[#:on-presence] handler runs, installing a second endpoint
+  @racket[on-presence] handler runs, installing a second endpoint
   and sending the @racket['ping] message.}
 
   @item{Process A's endpoint receives the @racket['ping] message, and
@@ -426,7 +354,7 @@ The sequence of events will be:
   @item{Process B's second endpoint receives the @racket['pong]
   message, and deletes both of process B's endpoints.}
 
-  @item{The @racket[#:on-absence] handler in process A runs, sending
+  @item{The @racket[on-absence] handler in process A runs, sending
   the @racket['pinger-departed] message.}
 
 #:style 'ordered]
@@ -439,19 +367,25 @@ One possible trace of messages in the VM containing processes A and B is
 	     'pinger-departed]
 
 By sending the @racket['ping] message @emph{only} once the
-@racket[#:on-presence] handler has fired, process B ensures that
+@racket[on-presence] handler has fired, process B ensures that
 someone is listening for pings.
 
 This way, if process B starts before process A, then B will
 automatically wait until A is ready to receive ping requests before
 issuing any.
 
+}
+
 @subsection{Exit reasons}
 
-If a @racket[#:reason] pattern is supplied, then the exit reason
-supplied to the @racket[delete-endpoint] or @racket[quit] action that
-led to the @racket[absence-event] is available to the endpoint's
-@racket[#:on-absence] handler expression.
+@defform[(match-reason pattern handler ...)]{
+
+If a handler is wrapped in a @racket[match-reason] form, then the exit
+reason supplied to the @racket[delete-endpoint] or @racket[quit]
+action that led to the @racket[absence-event] is available to the
+endpoint's @racket[on-absence] handler expression.
+
+}
 
 @subsection[#:tag "updating-endpoints"]{Updating endpoints}
 
@@ -468,24 +402,91 @@ automatic support for avoiding such transients.
 
 @subsection{Who am I talking to?}
 
-If either @racket[#:role] or any of @racket[#:peer-orientation],
-@racket[#:conversation], or @racket[#:peer-interest-type] are
-supplied, the @racket[handler-expr]s are given access to the role
-carried in the @racket[EndpointEvent] that triggered them.
+@deftogether[(
+@defform[(match-orientation pattern handler ...)]
+@defform[(match-conversation pattern handler ...)]
+@defform[(match-interest-type pattern handler ...)]
+)]{
 
-This role describes the @emph{intersection of interests} between the
-current endpoint and the peer endpoint, and so can proxy for the
-identity of the other party. It is in a sense a description of the
-scope of the current conversation.
+Wrapping a handler in @racket[match-orientation],
+@racket[match-conversation], and/or @racket[match-interest-type] gives
+a handler access to the contents of the @racket[role] structure
+carried in the triggering @racket[EndpointEvent].
 
-Using @racket[#:role] allows a handler complete access to the
-@racket[role] structure in the triggering event. It is more common
-however to simply use @racket[#:conversation] to extract the
-@racket[role-topic] alone, since it is seldom necessary to examine
+The carried role describes the @emph{intersection of interests}
+between the current endpoint and the peer endpoint, and so can proxy
+for the identity of the other party. It is in a sense a description of
+the scope of the current conversation.
+
+It is most common to simply use @racket[match-conversation] to extract
+the @racket[role-topic] alone, since it is seldom necessary to examine
 @racket[role-orientation] (since it's guaranteed to be complementary
 to the orientation of the current endpoint) or
-@racket[role-interest-type]. If access to those parts is required, use
-@racket[#:peer-orientation] and @racket[#:peer-interest-type].
+@racket[role-interest-type].
+
+See @secref{Examples} for examples of the use of
+@racket[match-conversation] and friends.
+
+}
+
+@subsection[#:tag "participating-vs-observing"]{Participating in a conversation vs. observing conversations}
+
+The core @racket[build-endpoint] form takes an expression evaluating
+to a @racket[role], rather than a simple topic. This gives full
+control over the new endpoint's @racket[Orientation] and
+@racket[InterestType].
+
+The other forms exist for convenience, since usually the orientation
+and interest-type is known statically, and only the topic varies
+dynamically:
+
+@itemlist[
+
+  @item{@racket[publisher] and @racket[subscriber] are for ordinary
+@emph{participation} in conversations;}
+
+  @item{@racket[observe-subscribers] and @racket[observe-publishers]
+are for @emph{observing} conversations without participating in them; and}
+
+  @item{@racket[observe-subscribers/everything] and
+@racket[observe-publishers/everything] are like the ordinary
+@tt{observe-...} variants, but use interest-type @racket['everything]
+instead of @racket['observer].}
+
+]
+
+The @racket[publisher], @racket[observe-subscribers] and
+@racket[observe-subscribers/everything] forms create
+@emph{publisher}-oriented endpoints, and @racket[subscriber],
+@racket[observe-publishers] and @racket[observe-publishers/everything]
+create @emph{subscriber}-oriented endpoints. The rationale for this is
+that as a participant, the code should declare the role being played;
+but as an observer, the code should declare the roles being observed.
+
+@subsection[#:tag "naming-endpoints"]{Naming endpoints}
+
+Endpoint names can be used to @seclink["updating-endpoints"]{update}
+or @seclink["deleting-endpoints"]{delete} endpoints.
+
+@defproc[(name-endpoint [id any/c] [add-endpoint-action AddEndpoint]) AddEndpoint]{
+
+Returns a copy of the passed-in @racket[add-endpoint] action
+structure, with the @racket[id] field set to the passed-in identifying
+value.
+
+}
+
+@defform[(let-fresh (identifier ...) expr ...)]{
+
+Binds the @racket[identifier]s to freshly-gensymmed symbols so that
+they are available to the @racket[exprs]. @racket[let-fresh] is useful
+for inventing a guaranteed-unused name for a temporary endpoint:
+
+@racketblock[(let-fresh (my-name)
+	       (name-endpoint my-name
+		 (subscriber ?
+		   (on-message [_ (list (delete-endpoint my-name)
+					...)]))))]
 
 }
 
@@ -526,22 +527,13 @@ Equivalent to @racket[(send-message body 'subscriber)].
 @section{Creating processes}
 
 @deftogether[(
-@defform[(spawn maybe-pid-binding maybe-debug-name maybe-parent-continuation
-		#:child boot-expr)]
-@defform[#:literals (:)
-	 (spawn: maybe-pid-binding maybe-debug-name typed-parent-continuation
-		 #:child : ChildStateType boot-expr)
+@defform[(spawn maybe-pid-binding boot-expr)]
+@defform[(spawn/continue maybe-pid-binding
+			 #:parent parent-state-pattern k-expr
+			 #:child boot-expr)
 	 #:grammar
 	 [(maybe-pid-binding (code:line)
 			     (code:line #:pid identifier))
-	  (maybe-debug-name (code:line)
-			    (code:line #:debug-name expr))
-	  (maybe-parent-continuation (code:line)
-				     (code:line #:parent k-expr)
-				     (code:line #:parent parent-state-pattern k-expr))
-	  (typed-parent-continuation (code:line #:parent : ParentStateType)
-				     (code:line #:parent : ParentStateType k-expr)
-				     (code:line #:parent parent-state-pattern : ParentStateType k-expr))
 	  (k-expr expr)
 	  (boot-expr expr)]]
 )]{
@@ -554,16 +546,20 @@ If @racket[#:pid] is supplied, the associated identifier is bound to
 the child process's PID in both @racket[boot-expr] and the parent's
 @racket[k-expr].
 
-Any supplied @racket[#:debug-name] will be used in VM debug output.
-See also @secref{logging}.
+The @racket[spawn/continue] variation includes a @racket[k-expr],
+which will run in the parent process after the child process has been
+created. Note that @racket[k-expr] must return a @racket[transition],
+since @racket[parent-state-pattern] is always supplied for these
+variations.
 
-If @racket[#:parent] is supplied, the associated @racket[k-expr] will
-run in the parent process after the child process has been created. If
-the @racket[parent-state-pattern] is also supplied, then
-@racket[k-expr] must return a @racket[Transition]; otherwise, it must
-return an @racket[ActionTree]. Note that in Typed Racket, for type
-system reasons, @racket[spawn:] requires @racket[ParentStateType] to
-be supplied.
+}
+
+@defproc[(name-process [id Any] [spawn-action Spawn]) Spawn]{
+
+Returns a copy of the passed-in @racket[spawn] action structure, with
+the @racket[debug-name] field set to the passed-in identifying value.
+The debug name of a process is used in VM debug output. See also
+@secref{logging}.
 
 }
 
@@ -591,40 +587,24 @@ itself.
 
 @section{Cooperative scheduling}
 
-@deftogether[(
-@defform[(yield maybe-state-pattern k-expr)]
-@defform[#:literals (:)
-	 (yield: typed-state-pattern k-expr)
-	 #:grammar
-	 [(maybe-state-pattern (code:line)
-			       (code:line #:state pattern))
-	  (typed-state-pattern (code:line : State)
-			       (code:line pattern : State))
-	  (k-expr expr)]]
-)]{
+@defform[(yield state-pattern k-expr)]{
 
 Lets other processes in the system run for a step, returning to
 evaluate @racket[k-expr] only after doing a complete round of the
 scheduler.
 
-If @racket[pattern] is supplied, @racket[k-expr] should evaluate to a
-@racket[Transition]; otherwise it should produce an @racket[ActionTree].
+The state of the yielding process will be matched against
+@racket[state-pattern] when the process is resumed, and
+@racket[k-expr] must evaluate to a @racket[transition].
 
 }
 
 @section{Creating nested VMs}
 
-@deftogether[(
-@defform[(nested-vm maybe-vm-pid-binding maybe-boot-pid-binding
-		    maybe-initial-state
-		    maybe-debug-name
-		    boot-action-expr ...)]
-@defform[#:literals (:)
-	 (nested-vm: : ParentStateType
-		     maybe-vm-pid-binding maybe-boot-pid-binding
-		     maybe-typed-initial-state
-		     maybe-debug-name
-		     boot-action-expr ...)
+@defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
+		   maybe-initial-state
+		   maybe-debug-name
+		   boot-action-expr ...)
 	 #:grammar
 	 [(maybe-vm-pid-binding (code:line)
 				(code:line #:vm-pid identifier))
@@ -632,12 +612,9 @@ If @racket[pattern] is supplied, @racket[k-expr] should evaluate to a
 				  (code:line #:boot-pid identifier))
 	  (maybe-initial-state (code:line)
 			       (code:line #:initial-state expr))
-	  (maybe-typed-initial-state (code:line)
-				     (code:line #:initial-state expr : StateType))
 	  (maybe-debug-name (code:line)
 			    (code:line #:debug-name expr))
-	  (boot-action-expr expr)]]
-)]{
+	  (boot-action-expr expr)]]{
 
 Results in a @racket[spawn] action that starts a nested VM. The
 primordial process in the new VM executes the boot-actions with the
@@ -654,10 +631,7 @@ primordial process in the new VM.
 
 @section{Relaying across layers}
 
-@deftogether[(
-@defform[#:literals (:) (at-meta-level: : StateType preaction ...)]
-@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]
-)]{
+@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]{
 
 Each VM gives its processes access to two distinct IPC facilities: the
 @emph{internal} one, provided for the VM's processes to talk amongst
@@ -666,38 +640,38 @@ itself is a process within.
 
 Marketplace's actions can apply to either of those two networks. By
 default, actions apply to the VM of the acting process directly, but
-using @racket[at-meta-level] (or @racket[at-meta-level:] in typed
-code) to wrap an action @emph{level-shifts} the action to make it
-apply at the level of the acting process's VM's container instead.
+using @racket[at-meta-level] to wrap an action @emph{level-shifts} the
+action to make it apply at the level of the acting process's VM's
+container instead.
 
 For example, wrapping an @racket[endpoint] in @racket[at-meta-level]
 adds a subscription to the VM's container's network. Instead of
 listening to sibling processes of the acting process, the new endpoint
 will listen to sibling processes of the acting process's VM. In this
-example, the primordial process in the @racket[nested-vm] creates an
+example, the primordial process in the nested VM creates an
 endpoint in the VM's own network, the ground VM:
 
 @racketblock[
-(nested-vm
+(spawn-vm
  (at-meta-level
-  (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?) ...)))
+  (subscriber (tcp-channel ? (tcp-listener 5999) ?) ...)))
 ]
 
 In this example, a new process is spawned as a sibling of the
-@racket[nested-vm] rather than as a sibling of its primordial process:
+nested VM rather than as a sibling of its primordial process:
 
 @racketblock[
-(nested-vm
+(spawn-vm
  (at-meta-level
-  (spawn #:child (transition/no-state (send-message 'hello-world)))))
+  (spawn (transition/no-state (send-message 'hello-world)))))
 ]
 
 Compare to this example, which spawns a sibling of the
-@racket[nested-vm]'s primordial process:
+nested VM's primordial process:
 
 @racketblock[
-(nested-vm
- (spawn #:child (transition/no-state (send-message 'hello-world))))
+(spawn-vm
+ (spawn (transition/no-state (send-message 'hello-world))))
 ]
 
 }

scribblings/lowlevel.scrbl

@@ -20,7 +20,7 @@ interface} of a Unix-like operating system.
 
 Each @deftech{handler function} is always associated with a particular
 @tech{endpoint}, registered with the VM via
-@racket[endpoint]/@racket[endpoint:]/@racket[add-endpoint]. A handler
+@racket[endpoint]/@racket[add-endpoint]. A handler
 function for a given process with state type @racket[State] has type:
 
 @racketblock[(EndpointEvent -> State -> (Transition State))]
@@ -41,8 +41,8 @@ Typed Racket types capturing various notions of handler function.
 
 @section{Messages, Topics and Roles}
 
-@declare-exporting[marketplace marketplace/sugar-untyped marketplace/sugar-typed
-		   #:use-sources (marketplace marketplace/sugar-untyped marketplace/sugar-typed)]
+@declare-exporting[marketplace marketplace/sugar
+		   #:use-sources (marketplace marketplace/sugar)]
 
 @deftogether[(
 @deftype[Message Any]
@@ -255,8 +255,8 @@ Deletes an existing endpoint named @racket[pre-eid]. The given
 
 If no specific reason is needed, it is conventional to supply
 @racket[#f] as the @racket[delete-endpoint-reason]. See also the
-convenience @from[marketplace/sugar-values]{@racket[delete-endpoint]}
-function from @racket[marketplace/sugar-values].
+convenience @from[marketplace/sugar]{@racket[delete-endpoint]}
+function from @racket[marketplace/sugar].
 
 }
 
@@ -270,9 +270,9 @@ the containing VM.} The given @racket[Orientation] should describe the
 role the sender is playing when sending this message: usually, it will
 be @racket['publisher], but when the message is @emph{feedback} for
 some publisher, it will be @racket['subscriber].
-@from[marketplace/sugar-values]{See also the @racket[send-message] and
+@from[marketplace/sugar]{See also the @racket[send-message] and
 @racket[send-feedback] convenience functions from
-@racket[marketplace/sugar-values].}
+@racket[marketplace/sugar].}
 
 }
 

scribblings/management-and-monitoring.scrbl

@@ -4,10 +4,7 @@
 
 @require[(for-label marketplace/support/spy
 		    marketplace/support/debug
-		    marketplace/log-untyped
-		    (except-in marketplace/log-typed
-			       marketplace-log
-			       marketplace-root-logger))]
+		    marketplace/log)]
 
 @title{Management and Monitoring}
 
@@ -31,8 +28,7 @@ each @racket['publisher] message sent to the VM's network.
 
 @section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
 
-@defmodule*[(marketplace/log-untyped
-	     marketplace/log-typed)]{
+@defmodule*[(marketplace/log)]{
 
 @defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
 

scribblings/prelude.inc

@@ -11,9 +11,8 @@
 	 (for-syntax racket)
 	 (for-label typed/racket/base))
 
-(require (for-label (except-in marketplace/sugar-untyped transition/no-state)
-		    (only-in marketplace/drivers/tcp-bare tcp)
-		    (except-in marketplace/sugar-typed ?)))
+(require (for-label (only-in marketplace/drivers/tcp-bare tcp)
+		    marketplace/sugar))
 
 ;; TODO: make it display "=" instead of ":" connecting the defined
 ;; type to the definition.

structs.rkt

@@ -0,0 +1,96 @@
+#lang racket/base
+
+(provide (all-defined-out))
+
+;; (define-type Orientation (U 'publisher 'subscriber))
+
+(struct role (orientation ;; Orientation
+	      topic ;; Topic
+	      interest-type ;; InterestType
+	      )
+	#:transparent)
+
+;; (define-type Message Topic) ;; Cheesy.
+
+;; (define-type InterestType (U 'participant 'observer 'everything))
+
+;; (define-type (Handler State) (TrapK EndpointEvent State))
+
+;; (define-type (InterruptK State) (State -> (Transition State)))
+;; (define-type (TrapK Event State) (Event -> (InterruptK State)))
+
+;; (define-type EndpointEvent (U PresenceEvent
+;; 			      AbsenceEvent
+;; 			      MessageEvent))
+
+(struct presence-event (role) #:transparent)
+(struct absence-event (role reason) #:transparent)
+(struct message-event (role message) #:transparent)
+
+(struct transition (state ;; State
+		    actions ;; (ActionTree State)
+		    )
+	#:transparent)
+
+;; (define-type (ActionTree State) (Constreeof (Action State)))
+
+;; Existential quantification over State
+;; (define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result))
+
+;; Specification of a new process
+(struct process-spec (boot ;; (PID -> CoTransition)
+		      )
+	#:transparent)
+;; (define-type ProcessSpec process-spec)
+
+;; (define-type (PreAction State) (U (add-endpoint State)
+;; 				  delete-endpoint
+;; 				  send-message
+;; 				  (spawn State)
+;; 				  quit))
+
+(struct add-endpoint (pre-eid ;; PreEID
+		      role ;; Role
+		      handler ;; (Handler State)
+		      )
+	#:transparent)
+
+(struct delete-endpoint (pre-eid ;; PreEID
+			 reason ;; Reason
+			 )
+	#:transparent)
+
+(struct send-message (body ;; Message
+		      orientation ;; Orientation
+		      )
+	#:transparent)
+
+(struct spawn (spec ;; process-spec
+	       k ;; (Option (PID -> (InterruptK State)))
+	       debug-name ;; Any
+	       )
+	#:transparent)
+
+(struct quit (pid ;; (Option PID) ;; #f = suicide
+	      reason ;; Reason
+	      )
+	#:transparent)
+
+;; (define-type (Action State) (U (PreAction State)
+;; 			       (yield State)
+;; 			       (at-meta-level State)))
+
+(struct yield (k ;; (InterruptK State)
+	       )
+	#:transparent)
+
+(struct at-meta-level (preaction ;; (PreAction State)
+		       )
+	#:transparent)
+
+;; (define-type PID Number)
+
+;;; Local Variables:
+;;; eval: (put 'transition 'scheme-indent-function 1)
+;;; eval: (put 'transition/no-state 'scheme-indent-function 0)
+;;; End:

sugar.rkt

@@ -0,0 +1,392 @@
+#lang racket/base
+
+(require (for-syntax syntax/parse))
+(require (for-syntax racket/base))
+
+(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 "support/dsl-untyped.rkt")
+
+(provide (all-from-out "main.rkt")
+
+	 transition
+	 delete-endpoint
+	 send-message
+	 send-feedback
+	 quit
+	 sequence-actions
+	 (rename-out [core:wild wild])
+
+	 name-endpoint
+	 let-fresh
+	 observe-subscribers
+	 observe-subscribers/everything
+	 observe-publishers
+	 observe-publishers/everything
+	 publisher
+	 subscriber
+	 build-endpoint
+
+	 ?
+	 transition/no-state
+	 spawn
+	 spawn/continue
+	 name-process
+	 yield
+	 at-meta-level
+	 spawn-vm
+	 ground-vm)
+
+;; transition : (All (State) State (core:ActionTree State) * -> (core:Transition State))
+(define (transition state . actions)
+  (core:transition state actions))
+
+(define (delete-endpoint id [reason #f])
+  (core:delete-endpoint id reason))
+
+;; send-message : (case-> [Any -> core:send-message]
+;; 			  [Any core:Orientation -> core:send-message])
+(define (send-message body [orientation 'publisher])
+  (core:send-message body orientation))
+
+(define (send-feedback body)
+  (core:send-message body 'subscriber))
+
+;; quit : (case-> [-> core:quit]
+;; 		  [(Option core:PID) -> core:quit]
+;; 		  [(Option core:PID) Any -> core:quit])
+(define (quit [who #f] [reason #f])
+  (core:quit who reason))
+
+;; sequence-actions : (All (State)
+;; 			   (core:Transition State)
+;; 			   (U (core:ActionTree State) (State -> (core:Transition State))) *
+;; 			   -> (core:Transition State))
+(define (sequence-actions t . more-actions-and-transformers)
+  (match-define (core:transition initial-state initial-actions) t)
+  (let loop ((state initial-state)
+	     (actions initial-actions)
+	     (items more-actions-and-transformers))
+    (match items
+      ['()
+       (core:transition state actions)]
+      [(cons item remaining-items)
+       (if (procedure? item)
+	   (match (item state)
+	     [(core:transition new-state more-actions)
+	      (loop new-state
+		    (cons actions more-actions)
+		    remaining-items)])
+	   (loop state
+		 (cons actions item)
+		 remaining-items))])))
+
+(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)
+
+(define (name-endpoint n e)
+  (match e
+    [(core:add-endpoint _ role handler)
+     (core:add-endpoint n role handler)]))
+
+(define-syntax-rule (let-fresh (id ...) exp ...)
+  (let ((id (gensym 'id)) ...) exp ...))
+
+(define-syntax-rule (observe-subscribers topic clause ...)
+  (build-endpoint (gensym 'anonymous-endpoint)
+		  (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 (publisher topic clause ...)
+  (build-endpoint (gensym 'anonymous-endpoint)
+		  (core:role 'publisher topic 'participant)
+		  clause ...))
+
+(define-syntax-rule (subscriber topic clause ...)
+  (build-endpoint (gensym 'anonymous-endpoint)
+		  (core:role 'subscriber topic 'participant)
+		  clause ...))
+
+(define-syntax build-endpoint
+  (lambda (stx)
+    (define (combine-handler-clauses clauses-stx
+				     stateful?
+				     state-stx
+				     orientation-stx
+				     conversation-stx
+				     interest-type-stx
+				     reason-stx)
+
+      (define (do-tail new-clauses-stx)
+	(combine-handler-clauses 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)
+	       #`(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
+				match-conversation
+				match-interest-type
+				match-reason
+				on-presence
+				on-absence
+				on-message)
+	[() '()]
+
+	[((match-state pat-stx inner-clause ...) outer-clause ...)
+	 (append (combine-handler-clauses (syntax (inner-clause ...))
+					  #t
+					  #'pat-stx
+					  orientation-stx
+					  conversation-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((match-orientation pat-stx inner-clause ...) outer-clause ...)
+	 (append (combine-handler-clauses (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  #'pat-stx
+					  conversation-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((match-conversation pat-stx inner-clause ...) outer-clause ...)
+	 (append (combine-handler-clauses (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  #'pat-stx
+					  interest-type-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((match-interest-type pat-stx inner-clause ...) outer-clause ...)
+	 (append (combine-handler-clauses (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  conversation-stx
+					  #'pat-stx
+					  reason-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((match-reason pat-stx inner-clause ...) outer-clause ...)
+	 (append (combine-handler-clauses (syntax (inner-clause ...))
+					  stateful?
+					  state-stx
+					  orientation-stx
+					  conversation-stx
+					  interest-type-stx
+					  #'pat-stx)
+		 (do-tail (syntax (outer-clause ...))))]
+
+	[((on-presence expr ...) outer-clause ...)
+	 (cons #`[(core:presence-event (core:role #,orientation-stx
+						  #,conversation-stx
+						  #,interest-type-stx))
+		  #,(stateful-lift 'on-presence (syntax (expr ...)))]
+	       (do-tail (syntax (outer-clause ...))))]
+
+	[((on-absence expr ...) outer-clause ...)
+	 (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 ...))))]
+
+	[((on-message [message-pat expr ...] ...) outer-clause ...)
+	 (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) (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 pre-eid-exp role-exp handler-clause ...)
+       #`(core:add-endpoint pre-eid-exp
+			    role-exp
+			    (match-lambda
+			     #,@(reverse
+				 (combine-handler-clauses
+				  (syntax (handler-clause ...))
+				  #f
+				  (syntax old-state)
+				  (syntax _)
+				  (syntax _)
+				  (syntax _)
+				  (syntax _)))
+			     [_ (lambda (state) (core:transition state '()))]))])))
+
+(define-syntax-rule (transition/no-state action ...)
+  (transition (void) action ...))
+
+;; A fresh unification variable, as identifier-syntax.
+(define-syntax ? (syntax-id-rules () (_ (wild))))
+
+(define-syntax spawn
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
+	  exp)
+       #`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
+		     #f
+		     #f)])))
+
+(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) (lambda (k) (k exp))))
+		     (lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
+		     #f)])))
+
+(define (name-process n p)
+  (match p
+    [(core:spawn spec parent-k _)
+     (core:spawn spec parent-k n)]))
+
+(define-syntax yield
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ state-pattern exp)
+       #'(core:yield (match-lambda [state-pattern exp]))])))
+
+(define (at-meta-level . preactions)
+  (match preactions
+    [(cons preaction '()) (core:at-meta-level preaction)]
+    [_ (map core:at-meta-level preactions)]))
+
+(define-syntax spawn-vm
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
+			  #:name "#:vm-pid")
+	       (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
+			  #:name "#:boot-pid")
+	       (~optional (~seq #:initial-state initial-state)
+			  #:defaults ([initial-state #'(void)])
+			  #:name "#:initial-state")
+	       (~optional (~seq #:debug-name debug-name)
+			  #:defaults ([debug-name #'#f])
+			  #:name "#:debug-name"))
+	  ...
+	  exp ...)
+       #`(core:make-nested-vm
+	  (lambda (vm-pid)
+	    (core:process-spec (lambda (boot-pid)
+				 (lambda (k) (k (core:transition initial-state
+								 (list exp ...)))))))
+	  debug-name)])))
+
+(define-syntax ground-vm
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
+			  #:name "#:boot-pid")
+	       (~optional (~seq #:initial-state initial-state)
+			  #:defaults ([initial-state #'(void)])
+			  #:name "#:initial-state"))
+	  ...
+	  exp ...)
+       #`(core:run-ground-vm
+	  (core:process-spec (lambda (boot-pid)
+			       (lambda (k) (k (core:transition initial-state
+							       (list exp ...)))))))])))
+
+;;; Local Variables:
+;;; eval: (put 'sequence-actions 'scheme-indent-function 1)
+;;; eval: (put 'name-process 'scheme-indent-function 1)
+;;; eval: (put 'yield 'scheme-indent-function 1)
+;;; 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 'publisher 'scheme-indent-function 1)
+;;; eval: (put 'subscriber '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:

support/debug.rkt

@@ -0,0 +1,105 @@
+#lang racket/base
+
+(require racket/match)
+
+(require (prefix-in core: "../main.rkt"))
+(require "../sugar.rkt")
+(require "../vm.rkt")
+(require "../process.rkt")
+(require "../quasiqueue.rkt")
+
+(require "gui.rkt")
+
+;; (define-type Debugger (All (S) (S -> S)))
+
+(provide debug)
+
+;; debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState))
+(define (debug spawn-child)
+  (match-define (core:spawn child-spec parent-k debug-name) spawn-child)
+  (core:spawn
+   (core:process-spec
+    (lambda (pid) ;; TODO: exploit this more in messages etc.
+      (define original-cotransition ((core:process-spec-boot child-spec) pid))
+      ;; wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R)
+      (define (wrapped-cotransition k)
+	;; receiver : (All (S) (Transition S) -> R)
+	(define (receiver child-transition)
+	  (define d (open-debugger debug-name))
+	  (k (wrap-transition d child-transition)))
+	(original-cotransition receiver))
+      wrapped-cotransition))
+   parent-k
+   (list 'debug debug-name)))
+
+;; wrap-transition : (All (ChildState)
+;; 			  Debugger
+;; 			  (Transition ChildState)
+;; 			  -> (Transition ChildState))
+(define (wrap-transition d child-transition0)
+  (define child-transition (d child-transition0))
+  (match-define (core:transition child-state child-actions) child-transition)
+  (core:transition child-state (action-tree-map (wrap-action d)
+						child-actions)))
+
+;; action-tree-map : (All (State) ((Action State) -> (Action State))
+;; 			  (ActionTree State)
+;; 			  -> (ActionTree State))
+(define (action-tree-map f actions)
+  (map f (quasiqueue->list (action-tree->quasiqueue actions))))
+
+;; wrap-action : (All (ChildState)
+;; 		      Debugger
+;; 		      -> ((Action ChildState) -> (Action ChildState)))
+(define ((wrap-action d) action)
+  (cond
+   [(core:yield? action)
+    (core:yield (wrap-interruptk d (core:yield-k action)))]
+   [(core:at-meta-level? action)
+    (core:at-meta-level (wrap-preaction #t d (core:at-meta-level-preaction action)))]
+   [else
+    (wrap-preaction #f d action)]))
+
+;; wrap-preaction : (All (ChildState)
+;; 			 Boolean
+;; 			 Debugger
+;; 			 (PreAction ChildState)
+;; 			 -> (PreAction ChildState))
+(define (wrap-preaction meta? d preaction)
+  (match preaction
+    [(core:add-endpoint pre-eid role handler)
+     (core:add-endpoint pre-eid role (wrap-handler meta? d handler))]
+    [(core:delete-endpoint pre-eid reason)
+     preaction]
+    [(core:send-message body orientation)
+     preaction]
+    [(core:spawn spec maybe-k child-debug-name)
+     (core:spawn spec (wrap-spawnk d maybe-k) child-debug-name)]
+    [(core:quit pid reason)
+     preaction]))
+
+;; wrap-interruptk : (All (ChildState)
+;; 			  Debugger
+;; 			  (InterruptK ChildState)
+;; 			  -> (InterruptK ChildState))
+(define (wrap-interruptk d ik)
+  (lambda (state)
+    (wrap-transition d (ik state))))
+
+;; wrap-spawnk : (All (ChildState)
+;; 		      Debugger
+;; 		      (Option (PID -> (InterruptK ChildState)))
+;; 		      -> (Option (PID -> (InterruptK ChildState))))
+(define (wrap-spawnk d maybe-k)
+  (and maybe-k
+       (lambda (child-pid) (wrap-interruptk d (maybe-k child-pid)))))
+
+;; wrap-handler : (All (ChildState)
+;; 		       Boolean
+;; 		       Debugger
+;; 		       (Handler ChildState)
+;; 		       -> (Handler ChildState))
+(define (wrap-handler meta?0 d h)
+  (lambda (event0)
+    (match-define (cons meta? event) (d (cons meta?0 event0)))
+    (wrap-interruptk d (h event))))

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)))
+	 ...))

support/gui.rkt

@@ -19,7 +19,7 @@
 
 (require racket/pretty)
 
-(require (prefix-in core: "../types.rkt")
+(require (prefix-in core: "../structs.rkt")
 	 (prefix-in core: "../vm.rkt"))
 
 (provide open-debugger)
@@ -55,20 +55,9 @@
 	 [name name]
 	 [from-vm to-debugger]
 	 [to-vm from-debugger]))
-  (wrap/unwrapper
-   (lambda (v)
-     (channel-put to-debugger v)
-     (channel-get from-debugger))))
-
-;; This is utterly vile.
-(define (wrap/unwrapper thunk)
-  (local-require racket/unsafe/ops)
-  (lambda (wrapped-val)
-    ;; (pretty-print `(wrapped-val ,wrapped-val))
-    (define inner (unsafe-struct-ref wrapped-val 0))
-    ;; (pretty-print `(inner ,inner))
-    (unsafe-struct-set! wrapped-val 0 (thunk inner))
-    wrapped-val))
+  (lambda (v)
+    (channel-put to-debugger v)
+    (channel-get from-debugger)))
 
 (define sane-tab-panel%
   (class tab-panel%
@@ -81,6 +70,13 @@
 	      (if h-stretch? width min-w)
 	      (if v-stretch? height min-h))))))
 
+(define (string->label-string s)
+  ;; Per documentation for (label-string?), a label string "is a
+  ;; string whose length is less than or equal to 200."
+  (if (> (string-length s) 200)
+      (string-append (substring s 0 196) " ...")
+      s))
+
 (define debugger%
   (class object%
 
@@ -271,12 +267,13 @@
 	  (select-state-tab))))
 
     (define (refresh-vm-display v)
-      (define procs (sort (hash->list (core:vm-processes v)) < #:key car))
+      ;; (define procs (sort (hash->list (core:vm-processes v)) < #:key car))
       (send vm-display clear)
-      (for [(entry (in-list procs))]
-	(match-define (cons pid wp) entry)
-	;;(wp (lambda (p) (displayln `(P ,p))))
-	(displayln (cons pid wp))))
+      ;; (for [(entry (in-list procs))]
+      ;; 	(match-define (cons pid wp) entry)
+      ;; 	;;(wp (lambda (p) (displayln `(P ,p))))
+      ;; 	(displayln (cons pid wp)))
+      )
 
     (define (select-state-tab)
       (define selection (send state-panel get-selection))
@@ -306,7 +303,7 @@
       (send events set-data n current-historical-moment)
       (send events set-string n dir 1)
       (send events set-string n type 2)
-      (send events set-string n (~a detail) 3)
+      (send events set-string n (string->label-string (~a detail)) 3)
       (define current-selection (send events get-selection))
       (when (or (not current-selection) (= current-selection (- n 1)))
 	(send events set-first-visible-item n)

support/spy.rkt

@@ -0,0 +1,30 @@
+#lang racket/base
+
+(require "../sugar.rkt")
+
+(provide generic-spy)
+
+;; generic-spy : (All (ParentState) Any -> (Spawn ParentState))
+(define (generic-spy label)
+  (name-process `(generic-spy ,label)
+    (spawn (transition (void)
+	     (observe-publishers (wild)
+	       (match-orientation orientation
+		 (match-conversation topic
+		   (match-interest-type interest
+		     (match-reason reason
+		       (on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
+					   (newline)
+					   (flush-output)
+					   '()))
+		       (on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
+					  (newline)
+					  (display reason)
+					  (newline)
+					  (flush-output)
+					  '()))
+		       (on-message
+			[p (begin (write `(,label MSG ,p))
+				  (newline)
+				  (flush-output)
+				  '())]))))))))))

vm.rkt

@@ -0,0 +1,104 @@
+#lang racket/base
+
+(require racket/match)
+(require "structs.rkt")
+(require "roles.rkt")
+(require "quasiqueue.rkt")
+
+(provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161)
+	 vm-next-process-id
+	 vm
+	 vm?
+
+	 (struct-out process)
+	 (struct-out endpoint)
+	 (struct-out eid)
+
+	 make-vm
+	 inject-process
+	 extract-process
+	 always-false
+	 reset-pending-actions
+	 process-map
+	 endpoint-fold)
+
+(struct vm (processes ;; (HashTable PID Process)
+	    next-process-id ;; PID
+	    )
+	#:transparent)
+
+(struct process (debug-name ;; Any
+		 pid ;; PID
+		 state ;; State
+		 spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
+		 endpoints ;; (HashTable PreEID (endpoint State))
+		 meta-endpoints ;; (HashTable PreEID (endpoint State))
+		 pending-actions ;; (QuasiQueue (Action State))
+		 )
+	#:transparent)
+
+(struct endpoint (id ;; eid
+		  role ;; role
+		  handler ;; (Handler State)
+		  )
+	#:transparent)
+
+(struct eid (pid ;; PID
+	     pre-eid ;; PreEID
+	     )
+	#:transparent)
+
+;;---------------------------------------------------------------------------
+
+;; make-vm : process-spec -> vm
+(define (make-vm boot)
+  (define primordial (process '#:primordial
+			      -1
+			      (void)
+			      (list)
+			      #hash()
+			      #hash()
+			      (quasiqueue (spawn boot #f '#:boot-process))))
+  (vm (hash-set #hash() (process-pid primordial) primordial) 0))
+
+;; inject-process : vm Process -> vm
+(define (inject-process state wp)
+  (struct-copy vm state [processes (hash-set (vm-processes state) (process-pid wp) wp)]))
+
+;; always-false : -> False
+(define (always-false) #f)
+
+;; extract-process : vm PID -> (values vm (Option Process))
+(define (extract-process state pid)
+  (define wp (hash-ref (vm-processes state) pid always-false))
+  (values (if wp
+	      (struct-copy vm state [processes (hash-remove (vm-processes state) pid)])
+	      state)
+	  wp))
+
+;; reset-pending-actions : (All (State) (process State) -> (process State))
+(define (reset-pending-actions p)
+  (struct-copy process p [pending-actions (empty-quasiqueue)]))
+
+;; process-map : (All (State) (process State) -> (process State)) vm -> vm
+;; TODO: simplify
+(define (process-map f state)
+  (for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))])
+    (let-values (((state wp) (extract-process state pid)))
+      (if (not wp)
+	  state
+	  (inject-process state (f wp))))))
+
+;; endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)
+(define (endpoint-fold f seed state)
+  (for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))])
+    (let-values (((state wp) (extract-process state pid)))
+      (if (not wp)
+	  seed
+	  (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))])
+	    (define ep (hash-ref (process-endpoints wp) pre-eid))
+	    (f wp ep seed))))))
+
+;;; Local Variables:
+;;; eval: (put 'unwrap-process 'scheme-indent-function 3)
+;;; End: