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

@@ -1,52 +1,69 @@
-# From Functional I/O to Functional Systems Programming
+# Marketplace: Bringing the Network into the Programming Language
 
-Support code for ICFP submission.
+Marketplace is a concurrent language able to express communication,
+enforce isolation, and manage resources. Network-inspired extensions
+to a functional core represent imperative actions as values, giving
+side-effects locality and enabling composition of communicating
+processes.
 
-This is a [Racket](http://racket-lang.org/) package containing a
-single
-[collection](http://docs.racket-lang.org/reference/collects.html),
+Collaborating programs are grouped within task-specific *virtual
+machines* (VMs) to scope their interactions. Conversations between
+programs are multi-party (using a publish/subscribe medium), and
+programs can easily participate in many such conversations at once.
+
+Marketplace makes *presence* notifications an integral part of
+pub/sub. Programs react to presence and absence notifications that
+report the comings and goings of their peers. Presence serves to
+communicate changes in demand for and supply of services, both within
+a VM and across *nested VM layers*. Programs can give up
+responsibility for maintaining presence information and for scoping
+group communications to their containing VM.
+
+## Documentation
+
+A (draft) manual for Marketplace is available
+[here](http://tonyg.github.io/marketplace/).
+
+## The code
+
+This repository contains a [Racket](http://racket-lang.org/) package,
 `marketplace`, which includes
 
- - the implementation of the `#lang marketplace` language from the
-   paper, 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/).
 
- - the echo server example from the paper, in
-   [`marketplace/examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/echo-paper.rkt).
+ - a TCP echo server example, in
+   [`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
 
- - the chat server example from the paper, in
-   [`marketplace/examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/marketplace/examples/chat-paper.rkt).
+ - a TCP chat server example, in
+   [`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
 
- - the Haskell, Erlang and Python implementations of the chat server
-   from the paper, 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),
+ - Haskell, Erlang and Python implementations of the chat server for comparison, in
+   [`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.
 
-## How to compile and run the code
+## Compiling and running the code
 
-You will need the latest **prerelease** version of Racket. Any version
-newer than or equal to Racket 5.3.3.7 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
@@ -59,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

@@ -0,0 +1,42 @@
+#lang racket/base
+
+(require racket/match)
+(require "structs.rkt")
+(require "roles.rkt")
+(require "vm.rkt")
+(require "log.rkt")
+(require "process.rkt")
+(require "action-delete-endpoint.rkt")
+(require "quasiqueue.rkt")
+
+(provide do-quit)
+
+;; 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)
+  (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)
+                         (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))
+      (let-values (((p state meta-actions) (delete-all-endpoints reason p state)))
+	(log-quit p)
+	(values #f state meta-actions))
+      (let-values (((state maybe-killed-wp) (extract-process state killed-pid)))
+	(if (not maybe-killed-wp)
+	    (values p state (empty-quasiqueue))
+	    (apply values
+		   (let ((killed-p maybe-killed-wp))
+		     (log-quit killed-p)
+		     (let-values (((killed-p state meta-actions)
+				   (delete-all-endpoints reason killed-p state)))
+		       (list p state meta-actions))))))))

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

@@ -0,0 +1,47 @@
+#lang racket/base
+
+(require racket/match)
+(require "structs.rkt")
+(require "roles.rkt")
+(require "vm.rkt")
+(require "log.rkt")
+(require "process.rkt")
+
+(provide do-spawn)
+
+;; 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
+  (define new-cotransition
+    (send-to-user* debug-name new-pid (e) (co-quit e)
+      ((process-spec-boot spec) new-pid)))
+  ;; co-quit : Reason -> CoTransition
+  (define ((co-quit e) k)
+    (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)
+    (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)))
+	   (new-cotransition transition-accepter))))
+    (values (if parent-k
+		(run-ready p (send-to-user p (e) (quit-interruptk e)
+			       (parent-k new-pid)))
+		p)
+	    (inject-process (struct-copy vm state [next-process-id (+ new-pid 1)])
+			    new-process))))

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,10 +62,14 @@
 		 (match remaining-actions
 		   ['()
 		    (next-process remaining-pids
-				  (inject-process state (mkProcess p))
+				  (inject-process state p)
 				  external-actions)]
 		   [(cons action remaining-actions)
-		    (matrix-log 'debug "PID ~v (~a) Action: ~v" pid (process-debug-name p) action)
+		    (marketplace-log 'debug
+				     "PID ~v (~a) Action: ~v"
+				     pid
+				     (process-debug-name p)
+				     action)
 		    (let-values (((p state new-external-actions)
 				  (perform-action action p state)))
 		      (if p
@@ -80,42 +83,42 @@
 					(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 (matrix-log 'info
-					  "PID ~v (~a) garbage-collected"
-					  pid
-					  (process-debug-name p))
+		       (begin (marketplace-log 'info
+					       "PID ~v (~a) garbage-collected"
+					       pid
+					       (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)))]
@@ -136,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)
@@ -176,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)
@@ -190,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
@@ -198,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 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 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 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 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> (TcpAddress TcpAddress -> BootK) -> Transition
-(define (maybe-spawn-socket r active-handles 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
-      [(ground? remote-addr) (transition active-handles)]
+      [(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

@@ -0,0 +1,88 @@
+#lang marketplace
+;; Equivalent to chat-paper.rkt, but using the raw unsugared
+;; structures rather than the friendly DSL overlay.
+
+(require racket/match)
+(require marketplace)
+
+(make-nested-vm
+ (lambda (vm-pid)
+   (process-spec (lambda (boot-pid)
+		   (lambda (k)
+		     (k (transition stateless
+				    (at-meta-level
+				     (add-endpoint 'listener
+						   (role 'subscriber
+							 (tcp-channel ? (tcp-listener 5999) ?)
+							 'observer)
+						   listener-event-handler))))))))
+ #f)
+
+(define listener-event-handler
+  (match-lambda
+   [(presence-event (role _ (tcp-channel them us _) _))
+    (lambda (state)
+      (transition state
+		  (spawn (process-spec (lambda (pid) (lambda (k) (k (chat-session them us)))))
+			 #f
+			 #f)))]
+   [_
+    (lambda (state) (transition state '()))]))
+
+(define (chat-session them us)
+  (define user (gensym 'user))
+  (transition stateless
+	      (list (listen-to-user user them us)
+		    (speak-to-user user them us))))
+
+(define (listen-to-user user them us)
+  (list
+   (at-meta-level
+    (add-endpoint 'tcp-receiver
+		  (role 'subscriber
+			(tcp-channel them us ?)
+			'participant)
+		  (match-lambda
+		   [(absence-event _ _)
+		    (lambda (state)
+		      (transition state (quit #f #f)))]
+		   [(message-event _ (tcp-channel _ _ (? bytes? text)))
+		    (lambda (state)
+		      (transition state (send-message `(,user says ,text) 'publisher)))]
+		   [_
+		    (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)
+    (at-meta-level
+     (send-message (tcp-channel us them (apply format fmt args))
+		   'publisher)))
+  (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
+    (add-endpoint 'tcp-sender
+		  (role 'publisher
+			(tcp-channel us them ?)
+			'participant)
+		  (lambda (event)
+		    (lambda (state) (transition state '())))))
+   (add-endpoint 'speech-subscriber
+		 (role 'subscriber
+		       `(,? says ,?)
+		       'participant)
+		 (match-lambda
+		  [(presence-event (role _ `(,who says ,_) _))
+		   (lambda (state) (transition state (announce who 'arrived)))]
+		  [(absence-event (role _ `(,who says ,_) _) _)
+		   (lambda (state) (transition state (announce who 'departed)))]
+		  [(message-event _ `(,who says ,what))
+		   (lambda (state) (transition state (say "~a: ~a" who what)))]))))

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,38 +31,38 @@
 		   "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
 	     ;; Not polling, and no events that could wake us from blocking, so quit
-	     (matrix-log 'debug "Ground VM returning normally.")
+	     (marketplace-log 'debug "Ground VM returning normally.")
 	     (sleep 0.2) ;; give the log-receivers a chance to drain (!)
 	     (void))
 	   (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

@@ -2,20 +2,19 @@
 
 (require racket/match)
 
-(provide matrix-root-logger
-	 matrix-log)
+(provide marketplace-root-logger
+	 marketplace-log)
 
-(define matrix-root-logger (make-logger 'typed-matrix #f))
+(define marketplace-root-logger (make-logger 'marketplace #f))
 
-;; WARNING: duplicated in log-typed.rkt
-(define-syntax matrix-log
+(define-syntax marketplace-log
   (syntax-rules ()
     [(_ level-exp message)
      (let ((level level-exp))
-       (when (log-level? matrix-root-logger level)
-	 (log-message matrix-root-logger level message #f)))]
+       (when (log-level? marketplace-root-logger level)
+	 (log-message marketplace-root-logger level message #f)))]
     [(_ level format-string exp ...)
-     (matrix-log level (format format-string exp ...))]))
+     (marketplace-log level (format format-string exp ...))]))
 
 (define (level-code level)
   (match level
@@ -26,10 +25,10 @@
     ['fatal "F"]
     [other (symbol->string other)]))
 
-(match (getenv "MATRIX_LOG")
+(match (getenv "MARKETPLACE_LOG")
   [#f (void)]
   [str (let ((level (string->symbol str)))
-	 (define receiver (make-log-receiver matrix-root-logger level))
+	 (define receiver (make-log-receiver marketplace-root-logger level))
 	 (thread
 	  (lambda ()
 	    (let loop ()

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/action-quit.rkt

@@ -1,45 +0,0 @@
-#lang typed/racket/base
-
-(require racket/match)
-(require "types.rkt")
-(require "roles.rkt")
-(require "vm.rkt")
-(require "log-typed.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)])
-
-(provide do-quit)
-
-(: 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))
-  (define (log-quit p)
-    (matrix-log (if reason 'warning 'info)
-		"PID ~v (~a) quits with reason: ~a"
-		killed-pid
-		(process-debug-name p)
-		(if (exn? reason)
-		    (exn->string reason)
-		    (format "~v" reason))))
-
-  (if (equal? killed-pid (process-pid p))
-      (let-values (((p state meta-actions) (delete-all-endpoints reason p state)))
-	(log-quit p)
-	(values #f state meta-actions))
-      (let-values (((state maybe-killed-wp) (extract-process state killed-pid)))
-	(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)
-		     (log-quit killed-p)
-		     (let-values (((killed-p state meta-actions)
-				   (delete-all-endpoints reason killed-p state)))
-		       (list p state meta-actions))))))))

marketplace/action-spawn.rkt

@@ -1,49 +0,0 @@
-#lang typed/racket/base
-
-(require racket/match)
-(require "types.rkt")
-(require "roles.rkt")
-(require "vm.rkt")
-(require "log-typed.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)))
-(define (do-spawn spec parent-k p debug-name state)
-  (define new-pid (vm-next-process-id state))
-  (matrix-log 'info "PID ~v (~a) starting" new-pid debug-name)
-  (: 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)
-  (define ((co-quit e) k)
-    ((inst k False) (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))))
-  (let ((new-process
-	 (send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e)))
-	   ((inst new-cotransition Process) transition-accepter))))
-    (values (if parent-k
-		(run-ready p (send-to-user p (e) (quit-interruptk e)
-			       (parent-k new-pid)))
-		p)
-	    (inject-process (struct-copy vm state [next-process-id (+ new-pid 1)])
-			    new-process))))

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 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 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 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 tcp-connection-manager)
-	       #:on-absence (maybe-forget-socket r active-handles)))))
-
-(define tcp (tcp-driver)) ;; pre-instantiated!
-
-(define (maybe-spawn-socket r active-handles driver-fun)
-  (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)]
-      [(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])
-	 #:prefab)
-
-(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])
-	 #:prefab)
-
-(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,229 +0,0 @@
-#lang typed/racket/base
-;; UDP driver.
-
-(require racket/set)
-(require racket/match)
-(require racket/udp)
-(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])
-	 #:prefab)
-(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])
-	 #:prefab)
-(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])
-	 #:prefab)
-(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])
-	 #:prefab)
-(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])
-	 #:prefab)
-(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-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/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/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"
-	       [matrix-root-logger Logger])
-
-;; WARNING: duplicated in log-untyped.rkt
-(define-syntax matrix-log
-  (syntax-rules ()
-    [(_ level-exp message)
-     (let ((level level-exp))
-       (when (log-level? matrix-root-logger level)
-	 (log-message matrix-root-logger level message #f)))]
-    [(_ level format-string exp ...)
-     (matrix-log level (format format-string exp ...))]))
-
-(provide matrix-root-logger
-	 matrix-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/sugar-typed.rkt

@@ -1,210 +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])
-				 ((inst core:transition State) 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] ...
-			     [_ ((inst core:transition State) state '())])]))
-		    #`(lambda: ([state : State])
-			((inst core:transition State)
-			 state
-			 (match message
-			   [message-pattern clause-body] ...
-			   [_ '()]))))])))])))
-
-(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,179 +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] ...
-					   [_ '()]))))])))])))
-
-(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 #:let-pid vm-pid) #:defaults ([vm-pid #'p0])
-			  #:name "#:vm-pid")
-	       (~optional (~seq #:let-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/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])
-	 #:prefab)
-(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]) #:prefab)
-(struct: absence-event ([role : Role] [reason : Reason]) #:prefab)
-(struct: message-event ([role : Role] [message : Message]) #:prefab)
-(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)])
-	 #:prefab)
-(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)])
-	 #:prefab)
-(define-type (AddEndpoint State) (add-endpoint State))
-
-(struct: delete-endpoint ([pre-eid : PreEID]
-			  [reason : Reason])
-	 #:prefab)
-(define-type DeleteEndpoint delete-endpoint)
-
-(struct: send-message ([body : Message]
-		       [orientation : Orientation])
-	 #:prefab)
-(define-type SendMessage send-message)
-
-(struct: (State)
-	 spawn ([spec : process-spec]
-		[k : (Option (PID -> (InterruptK State)))]
-		[debug-name : Any])
-	 #:prefab)
-(define-type (Spawn State) (spawn State))
-
-(struct: quit ([pid : (Option PID)] ;; #f = suicide
-	       [reason : Reason])
-	 #:prefab)
-(define-type Quit quit)
-
-(define-type (Action State) (U (PreAction State)
-			       (yield State)
-			       (at-meta-level State)))
-
-(struct: (State)
-	 yield ([k : (InterruptK State)])
-	 #:prefab)
-(define-type (Yield State) (yield State))
-
-(struct: (State)
-	 at-meta-level ([preaction : (PreAction State)])
-	 #:prefab)
-(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])
-	 #:prefab)
-
-(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,56 +18,49 @@
   (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)
-				   (matrix-log 'error "Process ~v(~v):~n~a~n"
-					       debug-name pid (exn-message e))
-				   (matrix-log 'error "Process ~v(~v):~n~v~n"
-					       debug-name pid e))
+				   (marketplace-log 'error "Process ~v(~v):~n~a~n"
+						    debug-name pid (exn-message e))
+				   (marketplace-log 'error "Process ~v(~v):~n~v~n"
+						    debug-name pid e))
 			       failure-result)])
-    (matrix-log 'debug "Entering process ~v(~v)" debug-name pid)
+    (marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
     (define result enclosed-expr)
-    (matrix-log 'debug "Leaving  process ~v(~v)" debug-name pid)
+    (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,39 +13,39 @@
 	 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))
 	 (mgu-canonical (freshen (role-topic left)) (freshen (role-topic right)))))
-  (matrix-log 'debug "role-intersection ~v // ~v --> ~v" left right result)
+  (marketplace-log 'debug "role-intersection ~v // ~v --> ~v" left right result)
   result)
 
 ;; True iff the flow between remote-role and local-role should be
@@ -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/.gitignore

@@ -0,0 +1 @@
+out/

scribblings/Makefile

@@ -0,0 +1,29 @@
+all: out
+
+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/*
+	cp -r out/marketplace/. pages/.
+	(cd pages; git add -A)
+	-(cd pages; git commit -m "Update $$(date +%Y%m%d%H%M%S)")
+	(cd pages; git push)
+	rm -rf pages
+
+out:
+	raco scribble \
+		--htmls \
+		--dest out \
+		++main-xref-in \
+		--redirect-main http://docs.racket-lang.org/ \
+		\
+		marketplace.scrbl
+
+clean:
+	rm -rf out

scribblings/background.scrbl

@@ -0,0 +1,115 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title{Background}
+
+@section{Network programming in the small}
+
+Even the simplest of programs can be seen as a network. This program
+sends a message containing @racket[3] and @racket[4] to @racket[+],
+and awaits a reply message, which contains @racket[7]:
+
+@interaction[(+ 3 4)]
+
+Subroutines are network services. Here, when the message @racket[3] is
+sent to @racket[add-four-to], it delegates to @racket[+]:
+
+@interaction[(define (add-four-to n) (+ n 4))
+	     (add-four-to 3)]
+
+@note{In π-calculus encodings of programs, replication and state are
+made explicit.} Immutable programs (of which stateless programs are a
+special case) are easily able to be @emph{replicated}; programs using
+mutable state, however, must be fixed in place. In fact, strictly
+speaking, it is the @emph{state} that must be fixed in place, not the
+program @emph{manipulating} the state. In the following program, the
+mutable @racket[total] variable must not be replicated:
+
+@interaction[(define accumulate
+	       (let ((total 0))
+		 (lambda (n)
+		   (set! total (+ total n))
+		   total)))
+	     (accumulate 3)
+	     (accumulate 4)
+	     (accumulate 0)]
+
+It would be a mistake to simply replace each occurrence of
+@racket[accumulate] with its definition, since three separate
+@racket[total] locations would be created. However, there is no
+problem replicating the @racket[lambda] term, so long as
+@racket[total] always refers to the same location:
+
+@interaction[(define total 0)
+	     ((lambda (n) (set! total (+ total n)) total) 3)
+	     ((lambda (n) (set! total (+ total n)) total) 4)
+	     ((lambda (n) (set! total (+ total n)) total) 0)]
+
+Programs raise exceptions to signal partial failure:
+
+@interaction[(define accumulate
+	       (let ((total 0))
+		 (lambda (n)
+		   (when (negative? n)
+		     (error 'accumulate "n must be non-negative!"))
+		   (set! total (+ total n))
+		   total)))
+	     (accumulate 3)
+	     (accumulate -2)]
+
+Programs can handle exceptions to @emph{contain} partial failure:
+
+@interaction[(with-handlers ([exn:fail? (lambda (e) 'ok)])
+	       (error 'oh-dear))]
+
+Partial failures interact with shared, mutable state in unpredictable
+ways, especially in larger programs that combine stateful subprograms.
+
+@note{For a good overview of PL-based approaches to security and
+trust, see Mark S. Miller's
+"@hyperlink["http://www.erights.org/talks/thesis/markm-thesis.pdf"]{Robust
+composition: Towards a unified approach to access control and
+concurrency control}" and Jonathan A. Rees's
+"@hyperlink["http://dspace.mit.edu/bitstream/handle/1721.1/5944/AIM-1564.pdf"]{A
+Security Kernel Based on the Lambda-Calculus}".} Programmers often
+ignore issues of security and trust between subprograms within a
+larger program. Most programming languages entirely lack any means of
+securely isolating subprograms from each other, leading to predictable
+failures. Even memory-safe languages such as Racket, Java and .NET
+only offer weak techniques for securely composing mutually suspicious
+subprograms. Techniques such as avoiding @emph{ambient authority} and
+using @emph{object capabilities} to compose subprograms
+
+TODO ^
+
+@section{Network programming in the large}
+
+Programs which engage in I/O are very obviously part of a network:
+
+@racketblock[(define (greet-user)
+	       (define username (read-line))
+	       (define greeting (format "Hello, ~a!\n" username))
+	       (display greeting)
+	       (newline))
+	     (greet-user)]
+
+Here, the network has two components: the program, and the user at the
+terminal.
+
+But look closely! There is a difference here between the kind of
+communication between this program and its @emph{peer} and the
+communication @emph{internal} to the program itself. Portions of the
+program relay information from the outside world, translating it to
+and from an internal representation as they go, while other portions
+perform computations on the relayed information.
+
+@vm-figure[(vm (vm-label "Operating System")
+	       (network-label "")
+	       (process "User")
+	       (process-space)
+	       (vm (vm-label "Program")
+		   (network-label "")
+		   (process "Read line")
+		   (process "Format greeting")
+		   (process "Print greeting")))]

scribblings/concepts.scrbl

@@ -0,0 +1,254 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title{Concepts}
+
+Marketplace integrates ideas from both distributed systems and
+virtualized operating system designs to obtain an architecture of
+nested @emph{virtual machines} (VMs). Each nested layer is equipped
+with its own publish/subscribe network that also propagates
+@emph{presence} information about the (dis)appearance of services.
+
+Throughout this manual, diagrams such as the following will illustrate
+various process structures:
+
+@vm-figure[(vm (vm-label "Ground Virtual Machine")
+	       (network-label "Ground-level Network Language")
+	       (process "A Process")
+	       (process "Another Process")
+	       (parameterize ((process-height (* 2/3 (process-height)))
+			      (vm-height (* 2 (vm-height))))
+		 (vm (vc-append (vm-label "Nested VMs are")
+				(vm-label "processes too"))
+		     (network-label "App-specific language")
+		     (process "Process")
+		     (process "Process")
+		     (process "Process")))
+	       (parameterize ((process-height (* 5/4 (process-height))))
+		 (process "Yet another process"))
+	       (parameterize ((process-height (* 2/3 (process-height))))
+		 (vm (vm-label "Another Nested VM")
+		     (network-label "Another language")
+		     (process "Process")
+		     (process "Process"))))]
+
+Rectangular boxes represent VMs. The processes running within each VM
+are placed atop its box. The narrow rectangular strip at the top of
+each VM's box represents the network connecting all the VM's processes
+to each other; it will frequently contain a short description of the
+protocols used for communication across the represented network.
+
+A central feature of Marketplace is that VMs are nothing more than
+regular processes, making them recursively nestable. Each VM supports
+a collection of processes all its own, and its internal IPC medium
+carries a VM-specific protocol that is often different from the
+protocol spoken by its containing VM.
+
+The outermost VM is called the @emph{ground VM}. The protocol spoken
+by processes running within the ground VM is a simple protocol
+relating Racket's @tech{synchronizable events} to Marketplace network
+messages. See @;{@secref{writing-new-drivers} and} @secref{Drivers} for
+information on using Racket events from Marketplace programs.
+
+@section{What is a process, what are event handlers?}
+
+A Marketplace @deftech{process} is a collection of @deftech{event
+handlers}, plus a piece of private @deftech{process state}. Every
+process@note{The exception to this rule is the Ground VM, which plays
+a special role.} runs within a containing VM.
+
+When an event occurs that is relevant to a process, one of its event
+handlers is called with the process's current state and a description
+of the event. The handler is expected to return an updated state value
+and a collection of actions for the containing VM to perform. An event
+handler, then, has the following approximate type:
+
+@centered{@italic{State} × @italic{Event} → @italic{State} × (Listof @italic{Action})}
+
+Event handlers are registered with the VM by creating @tech{endpoints}
+using the @racket[endpoint] macro (described in @secref{endpoint-dsl}) or
+the low-level @racket[add-endpoint] structure (described in
+@secref{endpoints-and-messages}).
+
+@deftech{Events}, passed to event handlers, describe the results of
+actions from the outside world, neighbouring processes in the VM, or
+the VM itself. They are implemented as @racket[struct]s. See
+@secref{endpoint-events} for a description of the available event
+structures.
+
+@deftech{Actions}, passed back to the VM by event handlers, describe
+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 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?}
+
+@deftech[#:key "vm"]{Virtual Machines (VMs)} are simply a collection
+of processes, plus a shared medium of communication that the contained
+processes use to communicate with each other. VMs offer access to both
+their own @emph{internal} network as well as to the @emph{external}
+network owned by the VM's own containing VM.@note{Again, the only
+exception here is the Ground VM, which interfaces to the underlying
+Racket system and so has no containing VM.}
+
+@section{Endpoints: Subscription and Advertisement}
+
+The Marketplace operating system's inter-process communication
+facility is structured around @deftech[#:key
+"pub/sub"]{publish/subscribe (pub/sub)} messaging.@note{For a survey
+of pub/sub messaging, see
+@hyperlink["http://www.cs.ru.nl/~pieter/oss/manyfaces.pdf"]{"The Many
+Faces of Publish/Subscribe"}, ACM Computing Surveys, Vol. 35, No. 2,
+June 2003, pp. 114–131. There's also plenty out there on the Internet;
+a good starting point is to google for
+@hyperlink["https://www.google.com/search?q=pub/sub message-oriented middleware"]{pub/sub message-oriented middleware}.}
+
+@deftech{Endpoints} are the representation of a process's engagement
+in some protocol. They pair a description of the process's @tech{role}
+in a conversation with an @tech{event handler} that responds to events
+relating to that role.
+
+A @deftech{role} describes the role some process is playing in a
+conversation. Concretely, roles are represented by @racket[Role]
+structures. A role can be used by the currently-running process to
+describe some role it wishes to play, or can be carried in some
+@racket[EndpointEvent] to describe the role some @emph{peer} process
+is playing in a conversation.
+
+Roles have three parts:
+
+@itemlist[
+
+  @item{An @deftech{orientation} (type @racket[Orientation]) describes
+  whether this role is concerned primarily with @emph{producing} or
+  @emph{consuming} messages.}
+
+  @item{A @deftech{topic} is a @deftech{pattern} over messages. Topics
+  perform double duty: they both scope conversations and filter
+  incoming messages. More on topics below.}
+
+  @item{An @deftech{interest-type} (type @racket[InterestType])
+  determines whether the endpoint playing the given role is genuinely
+  a participant in matching conversations or is simply observing the
+  real participants. See @secref{endpoint-dsl} for more on
+  interest-types.}
+
+]
+
+@section[#:tag "messages-and-topics"]{Messages and Topics}
+
+@declare-exporting[marketplace]
+
+@deftech{Messages} are simply Racket data structures. They can be any
+value for which @racket[equal?] is defined, any @racket[#:prefab]
+structure, most @racket[#:transparent] structures, or any non-object
+structure for which @racket[prop:struct-map] can be defined.
+
+As mentioned above, topics are simply patterns over messages. They are
+represented as normal data structures @emph{with embedded wildcards}.
+Use @racket[?] or @racket[(wild)] to construct a wildcard. For
+example, given the following definition,
+
+@racketblock[(struct chat-message (speaker text) #:transparent)]
+
+we can not only create instances that might be used with
+@racket[send-message],
+
+@racketblock[(chat-message "Tony" "Hello World!")]
+
+but also create topic patterns using @racket[?]. For example, this
+pattern matches anything said by @racket["Tony"]:
+
+@racketblock[(chat-message "Tony" ?)]
+
+This pattern matches chat-messages sent by anyone saying "Hello":
+
+@racketblock[(chat-message ? "Hello")]
+
+And finally, this pattern matches any chat-message at all:
+
+@racketblock[(chat-message ? ?)]
+
+Patterns can be nested. For instance, given the above definition of
+@racket[chat-message], the following pattern matches any chat message
+greeting anybody at all:
+
+@racketblock[(struct greeting (target) #:transparent)
+	     (chat-message ? (greeting ?))]
+
+@section{Presence}
+
+@deftech{Presence} (respectively its opposite, @deftech{absence}) is
+an indication that a matching conversational partner exists (resp. no
+longer exists) in the network. Presence can be used to synchronize
+conversations, setting up a conversational context before messages are
+sent.
+
+The term "presence" itself is lifted from Instant Messaging protocols
+like XMPP, where it describes the online/offline status of one's chat
+buddies. Here, it describes the online/offline status of peer
+processes, in terms of which conversations they are willing to engage
+in.
+
+The system derives presence information from the set of active pub/sub
+subscription and advertisement endpoints a process has created.
+Creating a new endpoint with a topic pattern that matches some other
+process's endpoint and an orientation @emph{opposite} to the other
+process's endpoint causes @racket[presence-event]s to be sent to both
+endpoints, informing them of the presence of the other. When a process
+crashes, or an endpoint is withdrawn with @racket[delete-endpoint], a
+corresponding @racket[absence-event] is sent to the remaining
+endpoint.
+
+@section{Nesting, relaying, and levels of discourse}
+
+Because VMs can be nested, and each VM has an IPC network of its own
+for the use of its processes, information sometimes needs to be
+relayed from a VM's external network to its internal network and vice
+versa.
+
+In general, the protocol messages sent across a VM's internal network
+may be quite different in syntax and meaning from those sent across
+the same VM's external network: consider the case of the
+@secref{chat-server-example}, which employs a nested VM to separate
+out TCP-related messages from higher-level, application-specific chat
+messages:
+
+@vm-figure[(vm (vm-label "Ground VM")
+	       (network-label "TCP")
+	       (process "TCP driver")
+	       (process "TCP listener")
+	       (process-space)
+	       (process "TCP socket mgr.")
+	       (process "TCP socket mgr.")
+	       (process-ellipsis)
+	       (process-space)
+	       (vm (vm-label "Nested VM")
+		   (network-label "(X says Y)")
+		   (process "Listener")
+		   (process-space)
+		   (process "Chat session")
+		   (process "Chat session")
+		   (process-ellipsis)))]
+
+Each VM's network corresponds to a distinct @emph{level of discourse}.
+The nesting of VMs is then roughly analogous to the layering of
+network protocol stacks. For example (and purely hypothetically!) the
+TCP-IP/HTTP/Webapp stack could perhaps be represented as
+
+@vm-figure[(vm (vm-label "Ground VM")
+	       (network-label "TCP/IP")
+	       (process "TCP driver")
+	       (vm (vm-label "HTTP VM")
+		   (network-label "HTTP sessions/reqs/reps")
+		   (process "HTTP accepter")
+		   (vm (vm-label "Session VM")
+		       (network-label "Session-specific msgs")
+		       (process "App process")
+		       (process-ellipsis))
+		   (process-ellipsis)))]

scribblings/drivers.scrbl

@@ -0,0 +1,209 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@require[(for-label marketplace/drivers/event-relay
+		    marketplace/drivers/tcp-bare)]
+
+@title{Drivers}
+
+@section{event-relay}
+
+@defmodule[marketplace/drivers/event-relay]{
+
+@defproc[(event-relay [self-id Symbol]) Spawn]{
+
+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
+debug-name @racket[`(event-relay ,self-id)].
+
+The relay process observes subscriptions matching the topic-pattern
+@racket[(cons (? evt?) _)], and when one appears, constructs an
+analogous one using @racket[at-meta-level] to connect to the next VM
+down the stack. Messages from the meta-level will be relayed up to the
+current level. When the subscription disappears, the relay withdraws
+the subscription at the meta-level as well.
+
+}
+
+}
+
+@section{tcp-bare}
+
+@defmodule[marketplace/drivers/tcp-bare]{
+
+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]{
+
+Returns a @racket[spawn] action which starts a TCP driver. The TCP
+driver should run either directly in a ground VM, or in a nested VM
+with a running @racket[event-relay].
+
+}
+
+@defthing[tcp Spawn]{
+
+A pre-made @racket[spawn] action equivalent to @racket[(tcp-driver)].
+
+}
+
+}
+
+@subsection{TCP channels}
+
+@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
+source, destination and subpacket. Each TCP connection has two such
+flows: one inbound (remote-to-local) bytestream, and one outbound
+(local-to-remote) bytestream.
+
+Packets carried by @racket[tcp-channel] structures are either
+end-of-file objects or raw binary data represented as Racket byte
+vectors.
+
+}
+
+@subsection{TCP addresses}
+
+A TCP address describes one end of a TCP connection. It can be either
+
+@itemlist[
+  @item{a @racket[tcp-address], representing a remote socket;}
+  @item{a @racket[tcp-handle], representing a local socket on a kernel-assigned port; or}
+  @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]{
+
+Describes a remote half-connection. The @racket[host] part is to be a
+string containing either a hostname (e.g. @racket["localhost"]) or an
+ASCII representation of an IP address (e.g. @racket["127.0.0.1"]).
+
+}
+
+@defstruct*[tcp-handle ([id any/c]) #:prefab]{
+
+Describes a local half-connection with a kernel-assigned port number.
+The port number is not directly accessible; the @racket[id] is used as
+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 @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].
+
+}
+
+@defstruct*[tcp-listener ([port (integer-in 0 65535)]) #:prefab]{
+
+Describes a local half-connection with a user-assigned port number.
+Use this to describe server sockets.
+
+}
+
+@subsection{Opening an outbound connection}
+
+Choose a @racket[tcp-handle], and then create endpoints as follows:
+
+@racketblock[
+(let ((local (tcp-handle 'some-unique-value))
+      (remote (tcp-address "the.remote.host.example.com" 5999)))
+  (transition/no-state
+   (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
+response to the presence of the endpoints. When the endpoints are
+deleted (or the process exits), the TCP driver will notice the absence
+and will close the underlying TCP socket.
+
+For a complete example, see @secref{chat-client-example}.
+
+@subsection{Accepting inbound connections}
+
+Choose a port number, and then create an @emph{observer} endpoint as
+follows:
+
+@racketblock[
+(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
+  (match-conversation (tcp-channel them us _)
+    (on-presence (spawn (chat-session them us)))))
+]
+
+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 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
+communicating on the newly-arrived socket.
+
+To illustrate the code for handling a newly-arrived connection,
+
+@racketblock[
+(define (chat-session them us)
+  (transition/no-state
+   (subscriber (tcp-channel them us ?)
+     (on-absence (quit))
+     (on-message [(tcp-channel _ _ (? bytes? data))
+		  (code:comment "Handle incoming data")
+		  (transition ...)]))))
+]
+
+@subsection{Receiving data}
+
+TCP-related messages will be of the form
+
+@racketblock[(tcp-channel remote-address local-address subpacket)]
+
+where the @racket[subpacket] is either @racket[eof] or a
+@racket[bytes?].
+
+@subsection{Sending data}
+
+Send data with
+
+@racketblock[(send-message (tcp-channel local-address remote-address subpacket))]
+
+where, as for receiving data, the @racket[subpacket] is either
+@racket[eof] or a @racket[bytes?].
+
+@;{
+@section{tcp}
+Not yet documented.
+}
+
+@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}
+
+For examples of the use of the UDP driver, see uses of
+@racket[udp-packet] etc. in
+@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/tk-dns.rkt"]{the
+Marketplace-based DNS resolver}.

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/from.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+;; Provides |from|, useful for importing identifiers from non-default
+;; contexts without spelling them differently.
+
+(require scribble/decode)
+
+(provide from)
+
+(define-syntax-rule (from require-spec pre-content ...)
+  (let ()
+    (local-require require-spec)
+    (splice (list pre-content ...))))

scribblings/highlevel.scrbl

@@ -0,0 +1,677 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title[#:tag "high-level-interface"]{High-level interface}
+
+@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
+@secref{low-level-interface} corresponds to the @emph{system call
+interface} of a Unix-like operating system.
+
+@section[#:tag "hashlang-variations"]{Using @tt{#lang marketplace} and friends}
+
+@;{
+@defmodulelang*[(marketplace
+		 marketplace/flow-control)]
+}
+
+@defmodulelang[marketplace]
+
+Programs written for Marketplace differ from normal Racket modules
+only in their selection of language. A Racket module written with
+@tt{#lang marketplace}, such as the echo server in
+@secref["echo-server-example"], specifies a sequence of definitions
+and startup @tech{actions} for an application. Typically, initial
+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 languages providing greater support for flow control,
+responsibility transfer, and other networking concepts.
+
+@;{
+@itemlist[
+
+  @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;}
+
+]
+}
+
+@section{Using Marketplace as a library}
+
+@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] 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
+           (subscriber (tcp-channel ? (tcp-listener 5999) ?)
+             (match-conversation (tcp-channel from to _)
+               (on-presence (spawn (echoer from to))))))
+]
+
+@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))
+	  (initial-action expr)]]{
+
+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)]
+
+@deftogether[(
+@defform[(transition new-state action-tree ...)]
+@defform[(transition/no-state action-tree ...)]
+)]{
+
+Each of these forms produces a @racket[transition] structure.
+
+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 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.
+
+}
+
+@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,
+and the @racket[transition-actions] are the actions that will be
+performed by the VM in order to apply the transition.
+
+}
+
+@defproc[(action-tree? [value any/c]) boolean?]{
+
+Predicate that recognises an @deftech{action tree}. An action tree is
+either
+
+@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.
+
+For example, all of the following are valid action trees which will
+send messages @racket[1], @racket[2] and @racket[3] in that order:
+
+@racketblock[(list (send-message 1)
+		   (send-message 2)
+		   (send-message 3))]
+
+@racketblock[(list (list (send-message 1))
+		   (cons (send-message 2) (cons '() (send-message 3))))]
+
+@racketblock[(cons (cons (send-message 1)
+			 (send-message 2))
+		   (list #f #f (send-message 3)))]
+
+Because @racket[#f] and @racket[(void)] are valid, ignored, members of
+an action-tree, @racket[and] and @racket[when] can be used to
+selectively include actions in an action-tree:
+
+@racketblock[(list (first-action)
+		   (when (condition?)
+		     (optional-action))
+		   (final-action))]
+
+@racketblock[(list (first-action)
+		   (and (condition?)
+			(optional-action))
+		   (final-action))]
+
+Finally, these inert placeholders can be used to represent "no action
+at all" in a transition:
+
+@racketblock[(transition new-state) (code:comment "No action-trees at all")
+	     (transition new-state '())
+	     (transition new-state (void))
+	     (transition new-state #f)]
+
+}
+
+@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
+of the supplied @racket[item]s is examined: if it is an
+@racket[ActionTree], it is appended to the pending transition's
+actions; if it is a procedure, it is called with the @emph{state} of
+the pending transition, and is expected to return an updated
+transition.
+
+For example,
+
+@racketblock[(sequence-actions (transition 'x
+				 (send-message (list 'message 0)))
+			       (send-message (list 'message 1))
+			       (send-message (list 'message 2))
+			       (lambda (old-state)
+				 (transition (cons 'y old-state)
+				   (send-message (list 'message 3))))
+			       (send-message (list 'message 4)))]
+
+produces the equivalent of
+
+@racketblock[(transition (cons 'y 'x)
+	       (send-message (list 'message 0))
+	       (send-message (list 'message 1))
+	       (send-message (list 'message 2))
+	       (send-message (list 'message 3))
+	       (send-message (list 'message 4)))]
+
+}
+
+@section[#:tag "endpoint-dsl"]{Creating endpoints}
+
+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
+collection of macros helps streamline endpoint setup.
+
+@deftogether[(
+@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 ...)]
+)]{
+
+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[(subscriber ?)]
+
+A minimal publishing endpoint would be:
+
+@racketblock[(publisher ?)]
+
+While topic patterns are ordinary Racket data with embedded @racket[?]
+wildcards (see @secref{messages-and-topics}), all the other patterns
+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}
+
+@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[(subscriber ?
+	       (on-message
+		['ping (send-message 'pong)]
+		['hello (list (send-message 'goodbye)
+			      (quit))]))]
+
+}
+
+}
+
+@subsection{Action-only vs. State updates}
+
+@defform[(match-state pattern handler ...)]{
+
+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}.
+
+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[(subscriber 'ping
+	       (on-message ['ping (send-message 'pong)]))]
+
+or, explicitly accessing the endpoint's process's state,
+
+@racketblock[(subscriber 'ping
+	       (match-state old-state
+		 (on-message ['ping (transition old-state
+				      (send-message 'pong))])))]
+
+}
+
+@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] handlers override this
+behaviour.
+
+For example, say process A establishes the following endpoint:
+
+@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[(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
+  @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
+  and sending the @racket['ping] message.}
+
+  @item{Process A's endpoint receives the @racket['ping] message, and
+  sends the @racket['pong] message.}
+
+  @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
+  the @racket['pinger-departed] message.}
+
+#:style 'ordered]
+
+One possible trace of messages in the VM containing processes A and B is
+
+@racketblock['pinger-arrived
+	     'ping
+	     'pong
+	     'pinger-departed]
+
+By sending the @racket['ping] message @emph{only} once the
+@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}
+
+@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}
+
+If, when an endpoint is created, an existing endpoint with an
+@racket[equal?] name is already present, then if the existing and
+to-be-added endpoints have exactly equal roles (meaning equal
+orientations, interest-types, and topic patterns), the @emph{handlers}
+for the endpoint are @emph{updated} without emitting presence or
+absence notifications.
+
+This dubious feature can be used to avoid "glitching" of presence
+signals. A future release of this library will include better
+automatic support for avoiding such transients.
+
+@subsection{Who am I talking to?}
+
+@deftogether[(
+@defform[(match-orientation pattern handler ...)]
+@defform[(match-conversation pattern handler ...)]
+@defform[(match-interest-type pattern handler ...)]
+)]{
+
+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].
+
+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].
+
+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)
+					...)]))))]
+
+}
+
+@section[#:tag "deleting-endpoints"]{Deleting endpoints}
+
+@defproc[(delete-endpoint [id Any] [reason Any #f]) Action]{
+
+Use this action to delete a previously-added endpoint by name. The
+@racket[id] given must be @racket[equal?] to the corresponding
+@racket[add-endpoint-pre-eid]; when @racket[endpoint] was used to
+construct the endpoint to be deleted, the relevant name is that bound
+by @racket[#:let-name] or supplied to @racket[#:name]. See
+@secref{naming-endpoints}.
+
+If @racket[reason] is supplied, it is included in the corresponding
+action, and made available in any resulting @racket[absence-event]s.
+
+}
+
+@section{Sending messages and feedback}
+
+@defproc[(send-message [body Any] [orientation Orientation 'publisher]) Action]{
+
+Constructs a message-sending action with the given orientation.
+Usually the correct orientation to use is @racket['publisher]; it
+means that the sender of the message is acting in the "publisher"
+role. Use @racket['subscriber] instead when acting in the "subscriber"
+role, i.e. sending feedback.
+
+}
+
+@defproc[(send-feedback [body Any]) Action]{
+
+Equivalent to @racket[(send-message body 'subscriber)].
+
+}
+
+@section{Creating processes}
+
+@deftogether[(
+@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))
+	  (k-expr expr)
+	  (boot-expr expr)]]
+)]{
+
+Action describing a new process to create. The @racket[boot-expr]
+should be an expression yielding a @racket[transition] that contains
+the child process's initial state and initial actions.
+
+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].
+
+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.
+
+}
+
+@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}.
+
+}
+
+@section{Exiting and killing processes}
+
+@defproc[(quit [who (Option PID) #f] [reason Any #f]) Action]{
+
+Action causing the termination of a process. If @racket[who] is
+omitted or @racket[#f], terminates the acting process; otherwise,
+terminates the peer process having @racket[who] as its PID.
+
+If @racket[reason] is supplied, it is included in the corresponding
+action, and made available in any resulting @racket[absence-event]s.
+
+Terminating the current process is as simple as:
+
+@racketblock[(quit)]
+
+When a process raises an exception that it does not catch, its
+containing VM catches the exception and turns it into an implicit quit
+action. In that case, the @racket[reason] will be the raised exception
+itself.
+
+}
+
+@section{Cooperative scheduling}
+
+@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.
+
+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}
+
+@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))
+	  (maybe-boot-pid-binding (code:line)
+				  (code:line #:boot-pid identifier))
+	  (maybe-initial-state (code:line)
+			       (code:line #:initial-state expr))
+	  (maybe-debug-name (code:line)
+			    (code:line #:debug-name 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
+given initial state. (If no initial state is supplied, @racket[(void)]
+is used.)
+
+If @racket[#:vm-pid] is present, the corresponding identifier is bound
+in the boot-action expressions to the container-relative PID of the
+new VM itself. If @racket[#:boot-pid] is present, however, the
+corresponding identifier is bound to the new-VM-relative PID of the
+primordial process in the new VM.
+
+}
+
+@section{Relaying across layers}
+
+@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
+themselves, and the @emph{external} one, the network that the VM
+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] 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 nested VM creates an
+endpoint in the VM's own network, the ground VM:
+
+@racketblock[
+(spawn-vm
+ (at-meta-level
+  (subscriber (tcp-channel ? (tcp-listener 5999) ?) ...)))
+]
+
+In this example, a new process is spawned as a sibling of the
+nested VM rather than as a sibling of its primordial process:
+
+@racketblock[
+(spawn-vm
+ (at-meta-level
+  (spawn (transition/no-state (send-message 'hello-world)))))
+]
+
+Compare to this example, which spawns a sibling of the
+nested VM's primordial process:
+
+@racketblock[
+(spawn-vm
+ (spawn (transition/no-state (send-message 'hello-world))))
+]
+
+}

scribblings/lowlevel.scrbl

@@ -0,0 +1,333 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title[#:tag "low-level-interface"]{Low-level interface}
+
+@defmodule[marketplace]
+
+At its heart, the interface between each @tech{process} and its
+containing @tech{VM} is based on @tech{handler functions} exchanging
+@tech{event} and @tech{action} structures with the VM. Both events and
+actions are simple Racket structures.
+
+This low-level interface between a VM and a process is analogous to
+the @emph{system call interface} of a Unix-like operating system. The
+@secref{high-level-interface} corresponds to the @emph{C library
+interface} of a Unix-like operating system.
+
+@section[#:tag "handler-functions"]{Handler Functions}
+
+Each @deftech{handler function} is always associated with a particular
+@tech{endpoint}, registered with the VM via
+@racket[endpoint]/@racket[add-endpoint]. A handler
+function for a given process with state type @racket[State] has type:
+
+@racketblock[(EndpointEvent -> State -> (Transition State))]
+
+That is, given an @racket[EndpointEvent] followed by the process's
+current state, the handler should reply with a @racket[Transition]
+containing a new process state and a collection of @racket[Action]s.
+
+@deftogether[(
+@deftype[(Handler State) (TrapK State)]
+@deftype[(TrapK State) (EndpointEvent -> (InterruptK State))]
+@deftype[(InterruptK State) (State -> (Transition State))]
+)]{
+
+Typed Racket types capturing various notions of handler function.
+
+}
+
+@section{Messages, Topics and Roles}
+
+@declare-exporting[marketplace marketplace/sugar
+		   #:use-sources (marketplace marketplace/sugar)]
+
+@deftogether[(
+@deftype[Message Any]
+@deftype[Topic Any]
+)]{
+
+As previously mentioned, @tech{messages} are ordinary Racket values,
+and @tech{topics} are ordinary Racket values which may have embedded
+wildcards.
+
+}
+
+@deftogether[(
+@defproc[(wild) Topic]
+@defthing[#:kind "syntax" ? Topic]
+)]{
+
+Each time @racket[?] (or @racket[(wild)]) is used in an expression
+context, it produces a fresh topic wildcard, suitable for use in a
+topic pattern.
+
+}
+
+@deftogether[(
+@defstruct*[role ([orientation Orientation] [topic Topic] [interest-type InterestType]) #:prefab]
+@deftype[Role role]
+)]{
+
+Roles are almost always constructed by the
+@racket[endpoint]/@racket[endpoint:] macros or by the VM
+implementations themselves. User programs generally only need to
+destructure @racket[role] instances.
+
+A @racket[role] describes the conversational role of a peer as seen by
+some process. For example, a subscriber to topic @racket['foo] with
+interest-type @racket['participant] might receive a presence
+notification carrying the role
+
+@racketblock[(role 'publisher 'foo 'participant)]
+
+Notice that the orientation of the role is the opposite of the
+orientation of the endpoint.
+
+}
+
+@deftype[Orientation (U 'publisher 'subscriber)]{
+
+Describes an endpoint's orientation: will it be acting as a publisher
+of messages, or as a subscriber to messages? Publishers (orientation
+@racket['publisher]) tend to use @racket[send-message] and tend to
+respond to feedback from subscribers; subscribers
+(@racket['subscriber]) tend to use @racket[send-feedback] and respond
+to messages from publishers.
+
+}
+
+@deftype[InterestType (U 'participant 'observer 'everything)]{
+
+Using interest-type @racket['participant] in an endpoint's role
+indicates that the endpoint is intending to act as a genuine
+participant in whatever protocol is associated with the endpoint and
+its topic.
+
+Using @racket['observer] indicates that the endpoint is intended to
+@emph{monitor} other ongoing (participant) conversations instead.
+Observer endpoints receive presence and absence notifications about
+participant endpoints, but participant endpoints only receive
+notifications about other participant endpoints, and not about
+observer endpoints.
+
+The @racket['observer] interest-type is intended to make it easier to
+monitor resource demand and supply. The monitoring endpoints/processes
+can react to changing demand by creating or destroying resources to
+match.
+
+Finally, the @racket['everything] interest-type receives notifications
+about presence and absence of @emph{all} the types of endpoint,
+@racket['participant], @racket['observer], and @racket['everything].
+Endpoints with interest-type @racket['everything] are rare: they are
+relevant for managing demand for @emph{observers}, as well as in some
+cases of cross-layer presence/absence propagation. Most programs (and
+even most drivers) will not need to use the @racket['everything]
+interest-type.
+
+}
+
+@section[#:tag "endpoint-events"]{Endpoint Events}
+
+@deftogether[(
+@deftype[EndpointEvent (U PresenceEvent AbsenceEvent MessageEvent)]
+@deftype[PresenceEvent presence-event]
+@deftype[AbsenceEvent absence-event]
+@deftype[MessageEvent message-event]
+)]{
+
+Endpoint events are passed to handler functions by VMs, conveying some
+change in the world the process lives in. An endpoint event can signal
+the arrival or departure of a conversational peer, or can deliver a
+message that has been sent on a VM's IPC facility.
+
+}
+
+@defstruct*[presence-event ([role Role]) #:prefab]{
+
+Indicates the arrival of a new conversational partner: an endpoint
+with a topic that intersects our own, with @racket[Orientation]
+opposite to our own.
+
+The @racket[presence-event-role] describes the arriving peer, or more
+precisely, describes the shared interest between ourselves and the new
+peer. In particular, the @racket[role-orientation] of the
+@racket[presence-event-role] is the orientation that the @emph{peer}
+supplied in its @racket[add-endpoint] structure.
+
+}
+
+@defstruct*[absence-event ([role Role] [reason Any]) #:prefab]{
+
+Indicates the departure of an existing conversational partner, through
+either an explicit @racket[delete-endpoint] action or the implicit
+deleting of all of a process's endpoints when a process exits.
+
+The @racket[absence-event-role] describes the departing peer,
+analogously to @racket[presence-event-role].
+
+}
+
+@defstruct*[message-event ([role Role] [message Message]) #:prefab]{
+
+Indicates the arrival of a message matching the topic pattern in the
+handler's @tech{endpoint}.
+
+}
+
+@section{Actions}
+
+@declare-exporting[marketplace]
+
+@deftogether[(
+@deftype[(Action State) (U (PreAction State)
+			   (yield State)
+			   (at-meta-level State))]
+@deftype[(PreAction State) (U (add-endpoint State)
+			      delete-endpoint
+			      send-message
+			      (spawn State)
+			      quit)]
+)]{
+
+Actions are requests from a process to its containing VM. If wrapped
+in an @racket[at-meta-level] structure, the action is to apply to
+@emph{the VM's own containing VM}; otherwise, the action applies to
+the process's containing VM.
+
+}
+
+@deftogether[(
+@defstruct*[at-meta-level ([preaction (PreAction State)]) #:prefab]
+@deftype[(AtMetaLevel State) (at-meta-level State)]
+)]{
+
+An @racket[at-meta-level] structure wraps a plain action, and makes it
+apply to the outer VM instead of the inner VM (the default).
+
+}
+
+@deftogether[(
+@defstruct*[yield ([k (InterruptK State)]) #:prefab]
+@deftype[(Yield State) (yield State)]
+)]{
+
+Because current VM implementations are cooperatively scheduled, it can
+sometimes be necessary to explicitly yield the CPU to other processes
+using a @racket[yield] action. When control returns to the yielding
+process, the @racket[yield-k] is invoked.
+
+}
+
+@subsection[#:tag "endpoints-and-messages"]{Endpoints and Messages}
+
+@deftogether[(
+@defstruct*[add-endpoint ([pre-eid Any] [role Role] [handler (Handler State)]) #:prefab]
+@deftype[(AddEndpoint State) (add-endpoint State)]
+)]{
+
+Creates a new endpoint subscribing to the given @racket[Role]. When
+events pertaining to the given role occur, the @racket[Handler] is
+invoked.@note{If invoked @racket[at-meta-level], subscribes to events
+in the containing VM's container.}
+
+The name of the new endpoint will be the @racket[pre-eid]; it must be
+unique within the current process, but otherwise can be any value at
+all. If the endpoint's name matches an existing endpoint, and the new
+role is the same as the existing endpoint's role, the handler function
+is @emph{replaced} in the existing endpoint.
+
+To delete an endpoint, perform a @racket[delete-endpoint] action built
+with the name of the endpoint to delete.
+
+}
+
+@deftogether[(
+@defstruct*[delete-endpoint ([pre-eid Any] [reason Any]) #:prefab]
+@deftype[DeleteEndpoint delete-endpoint]
+)]{
+
+Deletes an existing endpoint named @racket[pre-eid]. The given
+@racket[reason] is passed along to peer endpoints as part of an
+@racket[absence-event].
+
+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]{@racket[delete-endpoint]}
+function from @racket[marketplace/sugar].
+
+}
+
+@deftogether[(
+@defstruct*[send-message ([body Message] [orientation Orientation]) #:prefab]
+@deftype[SendMessage send-message]
+)]{
+
+Sends a message to peers.@note{Or, if @racket[at-meta-level], peers of
+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]{See also the @racket[send-message] and
+@racket[send-feedback] convenience functions from
+@racket[marketplace/sugar].}
+
+}
+
+@subsection{Process Management}
+
+@deftogether[(
+@defstruct*[spawn ([spec process-spec] [k (Option (PID -> (InterruptK State)))] [debug-name Any])
+		  #:prefab]
+@defstruct*[process-spec ([boot (PID -> CoTransition)]) #:prefab]
+@deftype[CoTransition
+	 (All (Result)
+	      (All (State) (Transition State) -> Result)
+	      -> Result)]
+@deftype[(Spawn State) (spawn State)]
+@deftype[ProcessSpec process-spec]
+)]{
+
+A @racket[spawn] requests the creation of a sibling process@note{If
+wrapped in an @racket[at-meta-level], the new process will instead be
+a sibling of the creating process's VM.}. The @racket[spawn-k] runs in
+the context of the @emph{creating} process, communicating to it the
+PID of the new process.
+
+The @racket[spawn-spec] describes the new process to be created. Its
+@racket[process-spec-boot] field is a function taking the PID of the
+new process and returning a "cotransition". Cotransitions use a
+second-order encoding of existential types to guarantee that the VM
+remains oblivious to the specific process state type of the new
+process. The downside of this approach is its syntactic and type
+complexity: see @racket[spawn:] for an easier-to-use, higher-level
+approach.
+
+}
+
+@deftogether[(
+@defstruct*[quit ([pid (Option PID)] [reason Any]) #:prefab]
+@deftype[Quit quit]
+)]{
+
+Kills a sibling process.@note{Or, if @racket[at-meta-level], a sibling
+process of the containing VM.} If @racket[quit-pid] is @racket[#f],
+kills the current process; otherwise, kills the process with the given
+PID. The @racket[quit-reason] is passed on to peers of
+currently-active endpoints in the process to be killed, as part of a
+@racket[absence-event], just as if each active endpoint were deleted
+manually before the process exited.
+
+If no specific reason is needed, it is conventional to supply
+@racket[#f] as the @racket[quit-reason].
+
+}
+
+@deftype[PID Number]{
+
+In the current VM implementations, process IDs are simply numbers.
+PIDs are scoped to and allocated by each individual VM instance.
+
+}

scribblings/management-and-monitoring.scrbl

@@ -0,0 +1,86 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@require[(for-label marketplace/support/spy
+		    marketplace/support/debug
+		    marketplace/log)]
+
+@title{Management and Monitoring}
+
+@section{generic-spy}
+
+@defmodule[marketplace/support/spy]{
+
+@defproc[(generic-spy [label Any]) Spawn]{
+
+Returns a @racket[spawn] action that, when executed, creates a process
+with a @racket[#:subscriber] @racket[endpoint] listening for every
+message. Each @racket[EndpointEvent] received by the endpoint is
+printed to the current output port. Using this process gives a crude
+trace of activity within a VM: @racket[presence-event]s and
+@racket[absence-event]s (of @racket[#:publishers]) are logged, as is
+each @racket['publisher] message sent to the VM's network.
+
+}
+
+}
+
+@section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
+
+@defmodule*[(marketplace/log)]{
+
+@defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
+
+Set the @tt{MARKETPLACE_LOG} environment variable to "debug", "info",
+"warning", "error" or "fatal" (i.e. any of Racket's
+@racket[log-level?]s) to enable output of log messages at that level
+and higher.
+
+If @tt{MARKETPLACE_LOG} is not defined in the environment, @emph{no log
+output will be produced}.
+
+}
+
+@defform[(marketplace-log level format-str arg ...)
+	 #:grammar
+	 ((level expr)
+	  (format-str expr)
+	  (arg expr))]{
+
+Analogous to Racket's core @racket[log-message], but uses
+@racket[marketplace-root-logger] instead of the system logger. The
+@racket[level] expression must evaluate to a level symbol (see
+@racket[log-level?]), and @racket[format-str] must evaluate to a
+format string for use with @racket[format].
+
+}
+
+@defthing[marketplace-root-logger logger?]{
+
+The root logger for marketplace logging.
+
+}
+
+}
+
+@section{debugger (experimental)}
+
+@defmodule[marketplace/support/debug]{
+
+@defproc[(debug [p Spawn]) Spawn]{
+
+Translates a @racket[spawn] action to another spawn action which wraps
+the to-be-spawned process in a debugging interface. Executing the
+resulting action will not only create a process in the executing VM,
+but will also open a debugger GUI.
+
+N.B.: The debugger is experimental and likely to change quite quickly
+and unpredictably.
+
+See the file @filepath["examples/debug-chat.rkt"] for an example of the
+use of @racket[debug].
+
+}
+
+}

scribblings/marketplace.scrbl

@@ -0,0 +1,76 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title[#:tag "marketplace"]{Marketplace: Network-Aware Programming}
+@;{Marketplace: A Functional Operating System}
+@;{Marketplace: A Functional Network Operating System}
+@;{Marketplace: A Functional Distributed Operating System}
+
+@author[(author+email "Tony Garnock-Jones" "tonyg@ccs.neu.edu")]
+
+@bold{Every program is a network.}
+This is the insight behind the π-calculus. Encoding a program as a
+π-calculus term shows it as a network of communicating processes. It
+is also one of the original inspirations for Smalltalk, where every
+object, every value, was imagined to be a separate computer in a vast
+network, and where objects communicated by message-passing.
+
+@bold{Every program is part of a network.}
+A program that computes a result but cannot communicate it is useless
+indeed. Every complete program both @emph{computes} and
+@emph{communicates}. Furthermore, it does so with some finite set of
+@emph{resources}, which it must carefully manage.
+
+@bold{Our programming languages do not recognise that every program is
+a network.} They blur the distinction between stateful and stateless
+portions of a program, making it difficult for programmers to reason
+about concurrency, contention, and distribution. They often treat
+partial failure as an afterthought, despite its importance in
+reasoning about program behaviour, particularly in connection with the
+effect of exceptions on stateful programs. They seldom consider issues
+of trust and security.
+
+@bold{Our programming languages do not recognise that every program is part of a network.}
+They treat communication with the outside world in an ad-hoc manner.
+They frequently treat network communication separately from
+@tt{1950s-style terminal input and output}. They force the programmer
+to divine failures in other parts of the network by arcane means such
+as timeouts and examining the entrails of dead communication channels.
+They offer no support for allocating or releasing local resources in
+response to changes in other parts of the network. They seldom
+consider issues of trust and security.
+
+@bold{Marketplace is a network-aware programming language.} As a
+corollary, because every program not only computes but also
+communicates and manages its resources, Marketplace is also a
+distributed operating system.
+
+By recognising that programs communicate both
+@emph{internally} (between subprograms) and @emph{externally} (between
+peers), we recognise an inherently recursive layered architecture. We
+see at every level the @emph{same} concerns of resource management,
+location of mutable state, failure detection and recovery, access
+control, I/O and user interface, debugging and profiling.
+
+Marketplace addresses these concerns with a small set of primitives
+chosen to make network programming in-the-small as flexible, scalable,
+manageable and securable as network programming in-the-large---and
+vice versa.
+
+@;{
+Networks must be manageable. Networks must be monitorable. Networks
+must tolerate partial failure. Networks must scale. Networks must
+communicate with other networks, via yet other networks.
+}
+
+@local-table-of-contents[]
+
+@;@include-section["background.scrbl"]
+@include-section["concepts.scrbl"]
+@include-section["highlevel.scrbl"]
+@include-section["lowlevel.scrbl"]
+@include-section["drivers.scrbl"]
+@;@include-section["writing-drivers.scrbl"]
+@include-section["management-and-monitoring.scrbl"]
+@include-section["examples.scrbl"]

scribblings/prelude.inc

@@ -0,0 +1,31 @@
+;; -*- scheme -*-
+(require scribble/racket
+	 scribble/eval
+	 scriblib/footnote
+
+	 slideshow/pict
+	 "vm-pictures.rkt"
+
+	 "from.rkt"
+
+	 (for-syntax racket)
+	 (for-label typed/racket/base))
+
+(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.
+(define-syntax deftype
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ (t a ...) d desc ...)
+       #`(defthing #:kind "type" t
+;; This is in column zero because scribble is overscrupulous about location preservation.
+#,(quasisyntax/loc #'d (All (a ...) d))
+	   desc ...)]
+      [(_ t d desc ...)
+       #`(defthing #:kind "type" t d desc ...)])))
+
+(define (vm-figure p)
+  (centered (to-element (render (scale p 1.2) #:target 'pict))))

scribblings/vm-pictures.rkt

@@ -0,0 +1,113 @@
+#lang racket/base
+
+(require (only-in racket/math pi))
+(require slideshow/pict)
+(require file/convertible)
+
+(provide (all-defined-out))
+
+(define default-process-height 98)
+
+(define default-font (make-parameter 'roman))
+
+(define final-border (make-parameter 1))
+
+(define process-angle (make-parameter 90))
+(define process-width (make-parameter 24))
+(define process-corner (make-parameter 6))
+(define process-height (make-parameter default-process-height))
+(define process-gap (make-parameter 6))
+(define process-fill-color (make-parameter "white"))
+
+(define PROCESS-SHADED (list #xdd #xdd #xdd))
+
+(define leg-offset (make-parameter 4))
+(define leg-width (make-parameter 2))
+(define leg-spot-width (make-parameter 4))
+
+(define (default-leg-height)
+  (/ (network-height) 2))
+
+(define (meta-leg-height)
+  (+ (default-leg-height) (vm-height) (network-height)))
+
+(define network-height (make-parameter 12))
+(define vm-height (make-parameter 27))
+(define process-label-size (make-parameter 12))
+(define network-label-size (make-parameter 9))
+(define vm-label-size (make-parameter 12))
+(define ellipsis-size (make-parameter 24))
+
+(define (process label)
+  (cb-superimpose
+   (colorize (filled-rounded-rectangle (process-width) (process-height) (process-corner))
+	     (process-fill-color))
+   (rounded-rectangle (process-width) (process-height) (process-corner))
+   (vc-append (text label (default-font) (process-label-size) (d2r (process-angle)))
+	      (blank (/ (- (process-width) (process-label-size)) 2)))))
+
+(define (process-group . ps)
+  (apply hb-append (process-gap) ps))
+
+(define (process-space [n 1])
+  (blank (+ (* (- n 1) (/ (process-width) 2))
+	    (- (/ (process-width) 2) (* 2 (process-gap)))) (process-height)))
+
+(define (vm-label str)
+  (text str (default-font) (vm-label-size) (d2r 0)))
+
+(define (network-label str)
+  (text str (default-font) (network-label-size) (d2r 0)))
+
+(define (vm label net-label . ps)
+  (define ps-pict (apply process-group ps))
+  (define label-width (max (pict-width label) (pict-width net-label)))
+  (define width (max (+ label-width (* 2 (max (vm-label-size) (network-label-size))))
+		     (pict-width ps-pict)))
+  (vl-append ps-pict
+	     (cb-superimpose (colorize (filled-rectangle width (network-height))
+				       (process-fill-color))
+			     (rectangle width (network-height))
+			     net-label)
+	     (cc-superimpose (colorize (filled-rectangle width (vm-height))
+				       (process-fill-color))
+			     (rectangle width (vm-height))
+			     label)))
+
+(define (process-ellipsis)
+  (cc-superimpose (text ". . ." (default-font) (ellipsis-size) 0)
+		  (blank 0 (process-height))))
+
+(define (d2r d)
+  (* pi (/ d 180.0)))
+
+(define (leg p offset height)
+  (define x (+ (/ (pict-width p) 2) (* offset (leg-offset))))
+  (define y (pict-height p))
+  (define leg-pict (vc-append (vline (leg-width) (- height (/ (leg-spot-width) 2)))
+			      (disk (leg-spot-width) #:draw-border? #f)))
+  (pin-over p (- x (/ (pict-width leg-pict) 2)) y leg-pict))
+
+(define (relay-legs p)
+  (leg (leg p 1 (default-leg-height)) -1 (meta-leg-height)))
+
+(define (local-leg p)
+  (leg p 0 (default-leg-height)))
+
+(define (render p #:target [target (string->symbol (or (getenv "VM_PICTURES_TARGET") "eps"))])
+  (define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
+					    (+ (pict-height p) (* 2 (final-border))))
+				     (panorama p)))
+  (case target
+    [(pict)
+     final-pict]
+    [(screen)
+     ;; FFS. This connects to the display even if you don't use it.
+     ;; (local-require racket/gui/base)
+     ;; (show-pict final-pict 800 600)
+     (log-error "You need to uncomment a couple of lines in vm-pictures.rkt")
+     (void)]
+    [(png)
+     (display (convert final-pict 'png-bytes))]
+    [(eps)
+     (display (convert final-pict 'eps-bytes))]))

scribblings/writing-drivers.scrbl

@@ -0,0 +1,12 @@
+#lang scribble/manual
+@require[racket/include]
+@include{prelude.inc}
+
+@title[#:tag "writing-new-drivers"]{Writing New Drivers}
+
+*** ground-vm's usage of Racket evt?s
+TODO
+example of chat-client.rkt
+
+*** pseudo-substruct
+TODO

struct-map.rkt

@@ -23,6 +23,10 @@
   (define m (cond
 	     [(struct-mappable? x) (extract-struct-mapper x)]
 	     [(prefab-struct-key x) => prefab-struct-mapper]
+	     [(struct? x)
+	      (define-values (struct-type skipped?) (struct-info x))
+	      (when skipped? (error name "Partial struct-info for ~v" x))
+	      (transparent-struct-mapper struct-type)]
 	     [else (error name "No struct-map property or mapper for ~v" x)]))
   (m f seed x))
 
@@ -33,3 +37,11 @@
       (define-values (new-field new-seed) (f old-field old-seed))
       (values (cons new-field new-fields) new-seed)))
   (values (apply make-prefab-struct key (reverse new-fields)) final-seed))
+
+(define ((transparent-struct-mapper struct-type) f initial-seed x)
+  (define-values (new-fields final-seed)
+    (for/fold ([new-fields '()] [old-seed initial-seed])
+	([old-field (cdr (vector->list (struct->vector x)))])
+      (define-values (new-field new-seed) (f old-field old-seed))
+      (values (cons new-field new-fields) new-seed)))
+  (values (apply (struct-type-make-constructor struct-type) (reverse new-fields)) final-seed))

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

@@ -0,0 +1,416 @@
+#lang racket/base
+
+(require racket/set)
+(require racket/match)
+(require racket/class)
+(require racket/async-channel)
+(require racket/gui/base)
+(require racket/date)
+(require racket/format)
+(require racket/math)
+
+(require images/icons/control)
+(require images/icons/arrow)
+(require images/icons/symbol)
+(require images/icons/misc)
+(require images/icons/style)
+
+(require data/queue)
+
+(require racket/pretty)
+
+(require (prefix-in core: "../structs.rkt")
+	 (prefix-in core: "../vm.rkt"))
+
+(provide open-debugger)
+
+;; Frame
+;;   Toolbar
+;;     Rewind one step - moves without executing
+;;     Fast-forward one step - moves without executing
+;;     --
+;;     Stop
+;;     Run one step
+;;     Play
+;;     --
+;;     Select history depth
+;;     --
+;;     Kill this process
+;;   State display
+;;     If the state is (vm?), special display; permits spawning debuggers on nested processes
+;;   Endpoints display
+;;     Shows ID and role 
+;;     Permits deletion of endpoint
+;;     Permits interaction with endpoint??
+;;   Trace display
+;;     Selection of a row rewinds to that point
+
+(struct historical-moment (alive? state endpoints) #:transparent)
+
+(define (open-debugger name)
+  (define to-debugger (make-channel))
+  (define from-debugger (make-channel))
+  (parameterize ((current-eventspace (make-eventspace)))
+    (new debugger%
+	 [name name]
+	 [from-vm to-debugger]
+	 [to-vm from-debugger]))
+  (lambda (v)
+    (channel-put to-debugger v)
+    (channel-get from-debugger)))
+
+(define sane-tab-panel%
+  (class tab-panel%
+    (super-new)
+    (define/override (place-children l width height)
+      (for/list [(child-spec (in-list l))]
+	(match-define (list min-w min-h v-stretch? h-stretch?) child-spec)
+	(list 0
+	      0
+	      (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%
+
+    (init-field name)
+    (init-field from-vm)
+    (init-field to-vm)
+
+    (define mutex (make-semaphore 1))
+    (define stepping? #t)
+    (define k-queue (make-queue))
+
+    (define (reply-to-vm reply)
+      (call-with-semaphore mutex
+       (lambda () (if stepping?
+		      (channel-put to-vm reply)
+		      (enqueue! k-queue reply)))))
+
+    (define current-historical-moment (historical-moment #t (void) '()))
+    (define displayed-endpoints '())
+    (define booted? #f)
+
+    (define frame (new frame%
+		       [label (format "~a" name)]
+		       [width 480]
+		       [height 700]))
+
+    (define menu-bar (new menu-bar% [parent frame]))
+    (define edit-menu (new menu% [label "Edit"] [parent menu-bar]))
+    (append-editor-operation-menu-items edit-menu #f)
+
+    (define state-panel (new sane-tab-panel%
+			     [parent frame]
+			     [choices '("Process State")]
+			     [callback (lambda (p e) (select-state-tab))]))
+
+    (define endpoints (new list-box%
+			   [style '(single column-headers)]
+			   [label #f]
+			   [choices '()]
+			   [parent frame]
+			   [columns '("ID" "" "" "" "Topic")]))
+
+    (define events (new list-box%
+			[style '(single column-headers)]
+			[callback (lambda (lb e)
+				    (define sel (or (send lb get-selection)
+						    (- (send lb get-number) 1)))
+				    (define m (and sel (send lb get-data sel)))
+				    (when m (select-historical-moment m)))]
+			[label #f]
+			[choices '()]
+			[parent frame]
+			[columns '("Time" "Dir" "Type" "Detail")]))
+
+    (define FIXED-COLUMN-WIDTH 40)
+    (send endpoints set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
+    (send endpoints set-column-width 2 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
+    (send endpoints set-column-width 3 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
+
+    (send events set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
+
+    (define toolbar (new horizontal-pane%
+			 [parent frame]
+			 [stretchable-height #f]
+			 [alignment '(right center)]))
+
+    (define (toolbar-button label [handler void])
+      (new button%
+	   [label label]
+	   [min-width 32]
+	   [parent toolbar]
+	   [callback handler]))
+
+    (define (toolbar-spacer)
+      (new pane% [parent toolbar] [min-width 16] [stretchable-width #f]))
+
+    ;; (toolbar-button (left-over-arrow-icon #:color syntax-icon-color))
+    ;; (toolbar-button (right-over-arrow-icon #:color syntax-icon-color))
+    ;; (toolbar-spacer)
+
+    (define pause-button
+      (toolbar-button (pause-icon #:color halt-icon-color)
+		      (lambda (b e)
+			(send pause-button enable #f)
+			(send play-button enable #t)
+			(send step-button enable #t)
+			(call-with-semaphore
+			 mutex
+			 (lambda ()
+			   (set! stepping? #f))))))
+    (define play-button
+      (toolbar-button (play-icon #:color run-icon-color)
+		      (lambda (b e)
+			(send pause-button enable #t)
+			(send play-button enable #f)
+			(send step-button enable #f)
+			(call-with-semaphore
+			 mutex
+			 (lambda ()
+			   (set! stepping? #t)
+			   (when (non-empty-queue? k-queue)
+			     (channel-put to-vm (dequeue! k-queue))))))))
+    (toolbar-spacer)
+    (define step-button
+      (toolbar-button (step-icon #:color run-icon-color)
+		      (lambda (b e)
+			(call-with-semaphore
+			 mutex
+			 (lambda ()
+			   (when (non-empty-queue? k-queue)
+			     (channel-put to-vm (dequeue! k-queue))))))))
+
+    (send play-button enable #f)
+    (send step-button enable #f)
+
+    ;; (toolbar-spacer)
+    ;; (toolbar-button "Settings...")
+    ;; (toolbar-spacer)
+    ;; (toolbar-button (stop-sign-icon))
+
+    (define status-indicator
+      (new canvas%
+	   [parent toolbar]
+	   [min-width 32]
+	   [min-height 32]
+	   [stretchable-width #f]
+	   [style '(transparent no-focus)]
+	   [paint-callback (lambda (c dc)
+			     (define mx (/ (send c get-width) 2))
+			     (define my (/ (send c get-height) 2))
+			     (define r (/ (min mx my) 2))
+			     (send dc set-brush
+				   (if (historical-moment-alive? current-historical-moment)
+				       "green"
+				       "red")
+				   'solid)
+			     (send dc draw-ellipse (- mx r) (- my r) (* r 2) (* r 2)))]))
+
+    (define state-text (new text%))
+    (define state-canvas (new editor-canvas%
+			      [parent state-panel]
+			      [editor state-text]
+			      [label "State"]))
+
+    (define vm-display (new list-box%
+			    [style '(single column-headers)]
+			    [label #f]
+			    [choices '()]
+			    [parent state-panel]
+			    [columns '("PID" "#Endpoints" "#MetaEndpoints" "Name")]))
+    (send vm-display show #f)
+
+    (define (select-historical-moment m)
+      (match-define (historical-moment alive? state new-endpoints) m)
+
+      (when (not (equal? displayed-endpoints new-endpoints))
+	(send endpoints clear)
+	(for [(ep (in-list new-endpoints))]
+	  (match-define (list pre-eid meta? (core:role orientation topic interest-type)) ep)
+	  (define n (send endpoints get-number))
+	  (send endpoints append (~v pre-eid))
+	  (send endpoints set-string n (if meta? "Meta" "") 1)
+	  (send endpoints set-string n (case orientation
+					 [(publisher) "Pub"]
+					 [(subscriber) "Sub"]) 2)
+	  (send endpoints set-string n (case interest-type
+					 [(participant) ""]
+					 [(observer) "Obs"]
+					 [(everything) "***"]) 3)
+	  (send endpoints set-string n (~v topic) 4))
+	(set! displayed-endpoints new-endpoints))
+
+      (send state-canvas set-canvas-background
+	    (if alive?
+		(make-color #xff #xff #xff)
+		(make-color #xff #xd0 #xd0)))
+
+      (send status-indicator refresh)
+
+      (send state-text erase)
+      (send state-text insert (pretty-format state))
+
+      (when (core:vm? state)
+	(refresh-vm-display state)
+	(when (= 1 (send state-panel get-number))
+	  (send state-panel append "VM State")
+	  (send state-panel set-selection 1)
+	  (select-state-tab))))
+
+    (define (refresh-vm-display v)
+      ;; (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)))
+      )
+
+    (define (select-state-tab)
+      (define selection (send state-panel get-selection))
+      (send state-canvas show (= selection 0))
+      (send vm-display show (= selection 1)))
+
+    (define controller-thread
+      (thread
+       (lambda ()
+	 (controller-thread-loop))))
+
+    (define (current-timestamp)
+      (define (p n w) (~a (exact-truncate n) #:width w #:align 'right #:pad-string "0"))
+      (define d (current-date))
+      (format "~a:~a:~a.~a ~a-~a-~a"
+	      (p (date-hour d) 2)
+	      (p (date-minute d) 2)
+	      (p (date-second d) 2)
+	      (p (/ (date*-nanosecond d) 1000000.0) 3)
+	      (date-year d)
+	      (p (date-month d) 2)
+	      (p (date-day d) 2)))
+
+    (define (record-event! stamp dir type detail)
+      (define n (send events get-number))
+      (send events append stamp)
+      (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 (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)
+	(send events set-selection n)
+	(select-historical-moment current-historical-moment)))
+
+    (define (format-action action)
+      (cond
+       [(core:yield? action)
+	(values "Yield" "")]
+       [(core:at-meta-level? action)
+	(format-preaction "Meta" (core:at-meta-level-preaction action))]
+       [else
+	(format-preaction "" action)]))
+
+    (define (format-preaction layer preaction)
+      (define-values (type detail)
+	(match preaction
+	  [(core:add-endpoint pre-eid role handler)
+	   (values "Sub" (string-append (format-role role) " " (~a pre-eid)))]
+	  [(core:delete-endpoint pre-eid reason)
+	   (values "Unsub" (format "~a ~v" pre-eid reason))]
+	  [(core:send-message body 'publisher)
+	   (values "Send" (~v body))]
+	  [(core:send-message body 'subscriber)
+	   (values "Feedback" (~v body))]
+	  [(core:spawn spec maybe-k child-debug-name)
+	   (values "Spawn" (~v child-debug-name))]
+	  [(core:quit #f reason)
+	   (values "Exit" (~v reason))]
+	  [(core:quit pid reason)
+	   (values "Kill" (format "~a ~v" pid reason))]))
+      (values (string-append layer type) detail))
+
+    (define (format-role r)
+      (match-define (core:role orientation topic interest-type) r)
+      (format "~a/~a ~v"
+	      (string-ref (symbol->string orientation) 0)
+	      (string-ref (symbol->string interest-type) 0)
+	      topic))
+
+    (define (apply-action! a)
+      (cond
+       [(core:yield? a) (void)]
+       [(core:at-meta-level? a) (apply-preaction! #t (core:at-meta-level-preaction a))]
+       [else (apply-preaction! #f a)]))
+
+    (define (apply-preaction! meta? p)
+      (match p
+	[(core:quit #f reason)
+	 (set! current-historical-moment
+	       (struct-copy historical-moment current-historical-moment
+		 [alive? #f]))]
+	[(core:add-endpoint pre-eid role handler)
+	 (set! current-historical-moment
+	       (struct-copy historical-moment current-historical-moment
+		 [endpoints (append (filter (lambda (e) (not (equal? (car e) pre-eid)))
+					    (historical-moment-endpoints
+					     current-historical-moment))
+				    (list (list pre-eid meta? role)))]))]
+	[(core:delete-endpoint pre-eid reason)
+	 (set! current-historical-moment
+	       (struct-copy historical-moment current-historical-moment
+		 [endpoints (filter (lambda (e) (not (equal? (car e) pre-eid)))
+				    (historical-moment-endpoints
+				     current-historical-moment))]))]
+	[_ (void)]))
+
+    (define (handle-from-vm x)
+      (define now (current-timestamp))
+      (match x
+	[(core:transition state actions)
+	 (when (or (not booted?)
+		   (not (equal? state (historical-moment-state current-historical-moment))))
+	   (set! booted? #t)
+	   (set! current-historical-moment
+		 (struct-copy historical-moment current-historical-moment [state state]))
+	   (record-event! now "Txn" "State" (~v state)))
+	 (let loop ((a actions))
+	   (cond
+	    [(pair? a) (loop (car a)) (loop (cdr a))]
+	    [(or (null? a) (eq? a #f) (void? a)) (void)]
+	    [else (define-values (type detail) (format-action a))
+		  (apply-action! a)
+		  (record-event! now "Act" type detail)]))
+	 (reply-to-vm x)]
+	[(cons meta? e)
+	 (define prefix (if meta? "Meta" ""))
+	 (match e
+	   [(core:presence-event role)
+	    (record-event! now "Evt" (string-append prefix "Presence") (format-role role))]
+	   [(core:absence-event role reason)
+	    (record-event! now "Evt" (string-append prefix "Absence")
+			   (string-append (format-role role) " " (~v reason)))]
+	   [(core:message-event _ message)
+	    (record-event! now "Evt" (string-append prefix "Recv") (~v message))])
+	 (reply-to-vm x)]))
+
+    (define (controller-thread-loop)
+      (sync (handle-evt from-vm
+			(lambda (x)
+			  (queue-callback (lambda () (handle-from-vm x)))
+			  (controller-thread-loop)))))
+
+    (super-new)
+
+    (select-historical-moment current-historical-moment)
+
+    (send frame show #t)
+    ))

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: