Profile both process-accounting and regular call-stack

README.md

@@ -30,40 +30,40 @@ This repository contains a [Racket](http://racket-lang.org/) package,
 `marketplace`, which includes
 
  - the implementation of the `#lang marketplace` language, in the
-   [top directory](https://github.com/tonyg/marketplace/tree/typeless/).
+   [top directory](https://github.com/tonyg/marketplace/tree/master/).
 
  - a TCP echo server example, in
-   [`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
+   [`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/examples/echo-paper.rkt).
 
  - a TCP chat server example, in
-   [`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
+   [`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/examples/chat-paper.rkt).
 
  - 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),
+   [`examples/chat.hs`](https://github.com/tonyg/marketplace/tree/master/examples/chat.hs),
-   [`chat.erl`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.erl),
+   [`chat.erl`](https://github.com/tonyg/marketplace/tree/master/examples/chat.erl),
    and
-   [`chat.py`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.py)
+   [`chat.py`](https://github.com/tonyg/marketplace/tree/master/examples/chat.py)
    respectively.
 
 ## Compiling and running the code
 
-You will need Racket version 6.1.x or later.
+You will need Racket version 5.90.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
+from the root directory of the Git checkout to install the package in
-from a local snapshot. (Alternatively, `make link` does the same thing.)
+your Racket system. (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
-[`examples/`](https://github.com/tonyg/marketplace/tree/typeless/examples/)
+[`examples/`](https://github.com/tonyg/marketplace/tree/master/examples/)
 directory.
 
 Note that both the echo server and chat server examples do not print
@@ -76,4 +76,4 @@ so you cannot run both simultaneously.
 
 ## Copyright
 
-Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014.
+Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013.

action-add-endpoint.rkt

@@ -1,15 +1,16 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.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
+(: do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
-;; 			  -> (values (Option (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)))
@@ -34,7 +35,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,44 +1,46 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "process.rkt")
-(require "quasiqueue.rkt")
+(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide do-delete-endpoint
 	 delete-all-endpoints)
 
-;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm
+(: do-delete-endpoint : (All (State) PreEID Reason (process State) vm
-;; 			     -> (values (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) (absence-event t reason))
+						    (lambda: ([t : Role]) (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
+(: delete-all-endpoints : (All (State) Reason (process State) vm
-;; 			       -> (values (process State) vm (QuasiQueue (Action vm))))
+			       -> (values (process State) vm (QuasiQueue (Action vm)))))
 (define (delete-all-endpoints reason p state)
   (let-values (((p state)
-		(for/fold ([p p] [state state])
+		(for/fold: : (values (process State) vm)
+		    ([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)
+	     (map (lambda (#{pre-eid : PreEID})
-		    (delete-endpoint (eid (process-pid p) pre-eid) reason))
+		    (delete-endpoint (cast (eid (process-pid p) pre-eid) PreEID)
+				     reason))
 		  (hash-keys (process-meta-endpoints p)))))))

action-quit.rkt

@@ -1,30 +1,31 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log.rkt")
+(require "log-typed.rkt")
 (require "process.rkt")
 (require "action-delete-endpoint.rkt")
-(require "quasiqueue.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
+(: do-quit : (All (State) PID Reason (process State) vm
-;; 		  -> (values (Option (process State)) vm (QuasiQueue (Action vm))))
+		  -> (values (Option (process State)) vm (QuasiQueue (Action vm)))))
 (define (do-quit killed-pid reason p state)
 
-  ;; log-quit : (All (KilledState) (process KilledState) -> Void)
+  (: log-quit : (All (KilledState) (process KilledState) -> Void))
   (define (log-quit p)
     (marketplace-log (if reason 'warning 'info)
 		     "PID ~v (~a) quits with reason: ~a"
 		     killed-pid
 		     (process-debug-name p)
 		     (if (exn? reason)
-                         (parameterize ([current-error-port (open-output-string)])
+			 (exn->string reason)
-                           ((error-display-handler) (exn-message reason) reason)
-                           (get-output-string (current-error-port)))
 			 (format "~v" reason))))
 
   (if (equal? killed-pid (process-pid p))
@@ -35,7 +36,9 @@
 	(if (not maybe-killed-wp)
 	    (values p state (empty-quasiqueue))
 	    (apply values
-		   (let ((killed-p maybe-killed-wp))
+		   (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)))

action-send-message.rkt

@@ -1,22 +1,24 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.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 ->
+(: do-send-message : (All (State) Orientation Message (process State) vm ->
-;; 			  (Values (Option (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 ([p p]) ([eid (in-hash-keys endpoints)])
+    (for/fold: : (process State) ([p p])
+	([eid (in-hash-keys endpoints)])
       (define e (hash-ref endpoints eid))
       (cond
        [(role-intersection message-role (endpoint-role e))

action-spawn.rkt

@@ -1,44 +1,46 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log.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)
+(: do-spawn : (All (OldState)
-;; 		   process-spec
+		   process-spec
-;; 		   (Option (PID -> (InterruptK OldState)))
+		   (Option (PID -> (InterruptK OldState)))
-;; 		   (process OldState)
+		   (process OldState)
-;; 		   Any
+		   Any
-;; 		   vm
+		   vm
-;; 		   -> (Values (Option (process OldState)) vm))
+		   -> (Values (Option (process OldState)) vm)))
 (define (do-spawn spec parent-k p debug-name state)
   (define new-pid (vm-next-process-id state))
   (marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name)
-  ;; new-cotransition : CoTransition
+  (: new-cotransition : CoTransition)
   (define new-cotransition
     (send-to-user* debug-name new-pid (e) (co-quit e)
       ((process-spec-boot spec) new-pid)))
-  ;; co-quit : Reason -> CoTransition
+  (: co-quit : Reason -> CoTransition)
   (define ((co-quit e) k)
-    (k (transition #f (quit #f e))))
+    ((inst k False) (transition #f (quit #f e))))
-  ;; transition-accepter : (All (NewState) (Transition NewState) -> Process)
+  (: transition-accepter : (All (NewState) (Transition NewState) -> Process))
   (define (transition-accepter t)
     (match-define (transition initial-state initial-actions) t)
-    (process debug-name
+    (mkProcess ((inst process NewState)
-	     new-pid
+		debug-name
-	     initial-state
+		new-pid
-	     '()
+		initial-state
-	     #hash()
+		'()
-	     #hash()
+		#hash()
-	     (action-tree->quasiqueue initial-actions)))
+		#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))))
+	   ((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)))

actions.rkt

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

drivers/event-relay.rkt

@@ -1,27 +1,30 @@
-#lang racket/base
+#lang typed/racket/base
 ;; Ground-event relay.
 
 (provide event-relay)
-(require "../sugar.rkt")
+(require "../sugar-typed.rkt")
+(require "../support/event.rkt")
 
-;; event-relay : (All (ParentState) Symbol -> (Spawn ParentState))
+(: event-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
 (define (event-relay self-id)
   (name-process `(event-relay ,self-id)
-    (spawn (transition/no-state
+    (spawn: #:parent : ParentState
-	     (observe-subscribers (cons ? ?)
+	    #:child : Void
-	       (match-conversation (cons (? evt? e) _)
+	    (transition/no-state
-		 (on-presence (begin
+	      (observe-subscribers: Void (cons ? ?)
-				(printf "SUBSCRIBED ~v~n" e)
+		(match-conversation (cons (? evt? e) _)
+		  (on-presence (begin
+				 (printf "SUBSCRIBED ~v~n" e)
+				 (flush-output)
+				 (at-meta-level: Void
+				   (name-endpoint `(event-relay ,self-id ,e)
+				     (subscriber: Void (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
+				(at-meta-level: Void
-				 (name-endpoint `(event-relay ,self-id ,e)
+				  (delete-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

@@ -5,9 +5,8 @@
 (require racket/match)
 (require (prefix-in tcp: racket/tcp))
 (require racket/port)
-(require "../sugar.rkt")
+(require "../sugar-untyped.rkt")
 (require "../support/dump-bytes.rkt")
-(require "../unify.rkt")
 
 (provide (struct-out tcp-address)
 	 (struct-out tcp-handle)

drivers/tcp-bare.rkt

@@ -5,7 +5,7 @@
 (require racket/match)
 (require (prefix-in tcp: racket/tcp))
 (require racket/port)
-(require "../sugar.rkt")
+(require "../sugar-untyped.rkt")
 (require "../support/dump-bytes.rkt")
 
 (provide (struct-out tcp-address)

drivers/tcp.rkt

@@ -5,9 +5,8 @@
 (require racket/match)
 (require (prefix-in tcp: racket/tcp))
 (require racket/port)
-(require "../sugar.rkt")
+(require "../sugar-untyped.rkt")
 (require "../support/dump-bytes.rkt")
-(require "../unify.rkt")
 
 (provide (struct-out tcp-address)
 	 (struct-out tcp-handle)

drivers/timer-untyped.rkt

@@ -0,0 +1,13 @@
+#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]))

drivers/timer.rkt

@@ -1,4 +1,4 @@
-#lang racket/base
+#lang typed/racket/base
 ;; Timer driver.
 
 ;; Uses mutable state internally, but because the scope of the
@@ -7,48 +7,103 @@
 
 (require racket/set)
 (require racket/match)
-(require data/heap)
+(require "../sugar-typed.rkt")
-(require "../sugar.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
+(struct: pending-timer ([deadline : Real]
-		       label ;; TimerLabel
+			[label : TimerLabel])
-		       )
+	 #:transparent)
-	#: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?
 
-(provide (struct-out set-timer)
-	 (struct-out timer-expired)
 	 timer-driver
 	 timer-relay)
 
-;; (define-type TimerKind (U 'relative 'absolute))
+(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 set-timer (label msecs kind) #:transparent)
+(struct: (TLabel TMsecs TKind)
+	 set-timer-repr ([label : TLabel]
+			 [msecs : TMsecs]
+			 [kind : TKind])
+	 #:transparent)
+
+(pseudo-substruct: (set-timer-repr TimerLabel Real TimerKind)
+		   SetTimer set-timer set-timer?)
+(pseudo-substruct: (set-timer-repr (U Wild TimerLabel)
+				   (U Wild Real)
+				   (U Wild TimerKind))
+		   SetTimerPattern set-timer-pattern set-timer-pattern?)
 
 ;; Message sent by the timer driver or a timer relay upon expiry of a
 ;; timer. Contains the label specified in the corresponding set-timer
 ;; message, and also the current absolute time from the outside world.
-(struct timer-expired (label msecs) #:transparent)
+(struct: (TLabel TMsecs)
+	 timer-expired-repr ([label : TLabel]
+			    [msecs : TMsecs])
+	 #:transparent)
+
+(pseudo-substruct: (timer-expired-repr TimerLabel Real)
+		   TimerExpired timer-expired timer-expired?)
+(pseudo-substruct: (timer-expired-repr (U Wild TimerLabel) (U Wild Real))
+		   TimerExpiredPattern timer-expired-pattern timer-expired-pattern?)
 
 ;; State of a timer-driver, including the identifier of the driver,
 ;; the currently-active subscription to ground time events (if any),
 ;; and the heap of all remaining timers.
-(struct driver-state (heap) #:transparent)
+(struct: driver-state ([heap : Heap]) #:transparent)
 
-;; (define-type RelayKey Exact-Nonnegative-Integer)
+(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
+(struct: relay-state ([next-counter : RelayKey]
-		     active-timers ;; (HashTable RelayKey TimerLabel)
+		      [active-timers : (HashTable RelayKey TimerLabel)])
-		     )
+	 #:transparent)
-	#:transparent)
 
-;; (define-type RelayState relay-state)
+(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)),
@@ -59,18 +114,18 @@
 ;; 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
+(: timer-evt : Real -> Evt)
 (define (timer-evt msecs)
   (wrap-evt (alarm-evt msecs)
 	    (lambda (_) (current-inexact-milliseconds))))
 
-;; make-timer-heap : -> Heap
+(: 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)
+(: next-timer! : Heap -> (Option pending-timer))
 (define (next-timer! heap)
   (if (zero? (heap-count heap))
       #f
@@ -78,7 +133,7 @@
 
 ;; 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)
+(: fire-timers! : Heap Real -> (Listof SendMessage))
 (define (fire-timers! heap now)
   (if (zero? (heap-count heap))
       '()
@@ -91,64 +146,70 @@
 
 ;; Process for mapping this-level timer requests to ground-level timer
 ;; events and back.
-;; timer-driver : (All (ParentState) -> (Spawn ParentState))
+(: timer-driver : (All (ParentState) -> (Spawn ParentState)))
 (define (timer-driver)
   (name-process 'timer-driver
-    (spawn (transition (driver-state (make-timer-heap))
+    (spawn: #:parent : ParentState
-	     (subscriber (set-timer (wild) (wild) (wild))
+	    #:child : DriverState
-	       (match-state state
+	    (transition: (driver-state (make-timer-heap)) : DriverState
-		 (on-message
+	      (subscriber: DriverState (set-timer-pattern (wild) (wild) (wild))
-		  [(set-timer label msecs 'relative)
+		(match-state state
-		   (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
+		  (on-message
-		  [(set-timer label msecs 'absolute)
+		   [(set-timer label msecs 'relative)
-		   (install-timer! state label msecs)])))
+		    (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
-	     (publisher (timer-expired (wild) (wild)))))))
+		   [(set-timer label msecs 'absolute)
+		    (install-timer! state label msecs)])))
+	      (publisher: DriverState (timer-expired-pattern (wild) (wild)))))))
 
-;; install-timer! : DriverState TimerLabel Real -> (Transition DriverState)
+(: 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)
+(: update-time-listener! : DriverState -> (Transition DriverState))
 (define (update-time-listener! state)
   (define next (next-timer! (driver-state-heap state)))
-  (transition state
+  (transition: state : DriverState
     (delete-endpoint 'time-listener)
     (and next
 	 (name-endpoint 'time-listener
-	   (subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
+	   (subscriber: DriverState (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)
+		   (sequence-actions (transition: state : DriverState)
-		     update-time-listener!
+				     update-time-listener!
-		     to-send))])))))))
+				     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))
+(: 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 '()))
+    (spawn: #:parent : ParentState
-	     (at-meta-level
+	    #:child : RelayState
-	      (subscriber (timer-expired (wild) (wild))
+	    (transition: (relay-state 0 (make-immutable-hash '())) : RelayState
+	      (at-meta-level: RelayState
+		(subscriber: RelayState (timer-expired-pattern (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))
+			  : RelayState
+			(and (hash-has-key? active-timers counter)
+			     (send-message (timer-expired (hash-ref active-timers counter)
+							  now))))]))))
+	      (subscriber: RelayState (set-timer-pattern (wild) (wild) (wild))
 		(match-state (relay-state next-counter active-timers)
 		  (on-message
-		   [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
+		   [(set-timer label msecs kind)
-				   now)
+		    (transition: (relay-state (+ next-counter 1)
-		    (transition (relay-state next-counter (hash-remove active-timers counter))
+					      (hash-set active-timers next-counter label))
-		      (and (hash-has-key? active-timers counter)
+			: RelayState
-			   (send-message (timer-expired (hash-ref active-timers counter)
+		      (at-meta-level: RelayState
-							now))))]))))
+			(send-message (set-timer (list self-id next-counter) msecs kind))))])))
-	     (subscriber (set-timer (wild) (wild) (wild))
+	      (publisher: RelayState (timer-expired-pattern (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-untyped.rkt

@@ -0,0 +1,21 @@
+#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]))

drivers/udp.rkt

@@ -1,20 +1,43 @@
-#lang racket/base
+#lang typed/racket/base
 ;; UDP driver.
 
 (require racket/set)
 (require racket/match)
-(require racket/udp)
 
-(require "../sugar.rkt")
+(require "../support/event.rkt")
+(require (except-in racket/udp udp-receive!-evt))
+(require/typed racket/udp
+	       [udp-receive!-evt (UDP-Socket Bytes -> Evt)])
 
-(provide (struct-out udp-remote-address)
+(require "../sugar-typed.rkt")
-	 (struct-out udp-handle)
+(require "../support/event.rkt")
-	 (struct-out udp-listener)
+(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)
+	 (struct-out udp-packet-repr)
+	 UdpPacket udp-packet udp-packet?
+	 UdpPacketPattern udp-packet-pattern udp-packet-pattern?
+
 	 udp-driver)
 
 ;; A UdpAddress is one of
@@ -25,122 +48,171 @@
 ;; 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: (THost TPort)
-(struct udp-handle (id) #:transparent)
+	 udp-remote-address-repr ([host : THost]
-(struct udp-listener (port) #:transparent)
+				  [port : TPort])
+	 #:transparent)
+(pseudo-substruct: (udp-remote-address-repr String Natural)
+		   UdpRemoteAddress udp-remote-address udp-remote-address?)
+(pseudo-substruct: (udp-remote-address-repr (U Wild String) (U Wild Natural))
+		   UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?)
 
-(define (udp-address? x)
+(struct: (TId)
-  (or (udp-remote-address? x)
+	 udp-handle-repr ([id : TId])
-      (udp-handle? x)
+	 #:transparent)
-      (udp-listener? x)))
+(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?)
 
-(define (udp-local-address? x)
+(struct: (TPort)
-  (or (udp-handle? x)
+	 udp-listener-repr ([port : TPort])
-      (udp-listener? x)))
+	 #:transparent)
+(pseudo-substruct: (udp-listener-repr Natural)
+		   UdpListener udp-listener udp-listener?)
+(pseudo-substruct: (udp-listener-repr (U Wild Natural))
+		   UdpListenerPattern udp-listener-pattern udp-listener-pattern?)
+
+(define-type UdpAddress (U UdpRemoteAddress UdpHandle UdpListener))
+(define-type UdpAddressPattern (U Wild UdpRemoteAddressPattern UdpHandlePattern UdpListenerPattern))
+
+(define-type UdpLocalAddress (U UdpHandle UdpListener))
+
+(define-predicate udp-address? UdpAddress)
+(define-predicate udp-address-pattern? UdpAddressPattern)
+(define-predicate udp-local-address? UdpLocalAddress)
 
 ;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
 ;; represents a packet appearing on our local "subnet" of the full UDP
 ;; network, complete with source, destination and contents.
-(struct udp-packet (source destination body) #:transparent)
+(struct: (TSource TDestination TBody)
+	 udp-packet-repr ([source : TSource]
+			  [destination : TDestination]
+			  [body : TBody])
+	 #:transparent)
+(pseudo-substruct: (udp-packet-repr UdpAddress UdpAddress Bytes)
+		   UdpPacket udp-packet udp-packet?)
+(pseudo-substruct: (udp-packet-repr UdpAddressPattern UdpAddressPattern (U Wild Bytes))
+		   UdpPacketPattern udp-packet-pattern udp-packet-pattern?)
 
 ;; A HandleMapping is a record describing a mapping between a local
 ;; UdpAddress and its underlying UDP socket. It's private to the
 ;; implementation of the driver.
-(struct handle-mapping (address socket) #:transparent)
+(struct: (TAddress TSocket)
+	 handle-mapping-repr ([address : TAddress]
+			      [socket : TSocket])
+	 #:transparent)
+(pseudo-substruct: (handle-mapping-repr UdpLocalAddress Any)
+		   ;; ^ TODO: Want to use UDP-Socket instead of Any here
+		   HandleMapping handle-mapping handle-mapping?)
+(pseudo-substruct: (handle-mapping-repr (U Wild UdpLocalAddress) (U Wild Any))
+		   HandleMappingPattern handle-mapping-pattern handle-mapping-pattern?)
 
 ;; TODO: BUG?: Routing packets between two local sockets won't work
 ;; because the patterns aren't set up to recognise that situation.
 
 ;; represents any remote address
-;; any-remote : UdpAddressPattern
+(: any-remote : UdpAddressPattern)
-(define any-remote (udp-remote-address (wild) (wild)))
+(define any-remote (udp-remote-address-pattern (wild) (wild)))
 
-;; (define-type DriverState (Setof UdpLocalAddress))
+(define-type DriverState (Setof UdpLocalAddress))
 
-;; (define-type SocketManagerState Boolean)
+(define-type SocketManagerState Boolean)
 
 ;; Process acting as a UDP socket factory.
-;; udp-driver : (All (ParentState) -> (Spawn ParentState))
+(: udp-driver : (All (ParentState) -> (Spawn ParentState)))
 (define (udp-driver)
 
-  ;; handle-presence : Topic DriverState -> (Transition DriverState)
+  (: handle-presence : Topic DriverState -> (Transition DriverState))
   (define (handle-presence topic active-handles)
-    (match-define (udp-packet _ (? udp-local-address? local-addr) _) topic)
+    (match-define (udp-packet-pattern _ (? udp-local-address? local-addr) _) topic)
     (cond
      [(set-member? active-handles local-addr)
-      (transition active-handles)]
+      (transition: active-handles : DriverState)]
      [else
-      (transition (set-add active-handles local-addr)
+      (transition: (set-add active-handles local-addr) : DriverState
 	(udp-socket-manager local-addr))]))
 
   (name-process 'udp-driver
-    (spawn (transition (set)
+    (spawn: #:parent : ParentState
+	    #:child : DriverState
+	    (transition: ((inst set UdpLocalAddress)) : DriverState
 
-	     (observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
+	      (observe-subscribers: DriverState
-	       (match-state active-handles
+		  (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-		 (match-conversation topic
+		(match-state active-handles
-		   (on-presence (handle-presence topic active-handles)))))
+		  (match-conversation topic
-	     (observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild))
+		    (on-presence (handle-presence topic active-handles)))))
-	       (match-state active-handles
+	      (observe-subscribers: DriverState
-		 (match-conversation topic
+		  (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
-		   (on-presence (handle-presence topic active-handles)))))
+		(match-state active-handles
-	     (observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
+		  (match-conversation topic
-	       (match-state active-handles
+		    (on-presence (handle-presence topic active-handles)))))
-		 (match-conversation topic
+	      (observe-publishers: DriverState
-		   (on-presence (handle-presence topic active-handles)))))
+		  (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
-	     (observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
+		(match-state active-handles
-	       (match-state active-handles
+		  (match-conversation topic
-		 (match-conversation topic
+		    (on-presence (handle-presence topic active-handles)))))
-		   (on-presence (handle-presence topic active-handles)))))
+	      (observe-publishers: DriverState
+		  (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
+		(match-state active-handles
+		  (match-conversation topic
+		    (on-presence (handle-presence topic active-handles)))))
 
-	     (observe-publishers (handle-mapping (wild) (wild))
+	      (observe-publishers: DriverState (handle-mapping-pattern (wild) (wild))
-	       (match-state active-handles
+		(match-state active-handles
-		 (match-conversation (handle-mapping local-addr socket)
+		  (match-conversation (handle-mapping local-addr socket)
-		   (on-absence
+		    (on-absence
-		    (transition (set-remove active-handles local-addr))))))
+		     (transition: (set-remove active-handles local-addr) : DriverState)))))
-	     ))))
+	      ))))
 
-;; bind-socket! : UDP-Socket UdpLocalAddress -> Void
+(: 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
+(: 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)
+(: 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)
+  (: handle-absence : SocketManagerState -> (Transition SocketManagerState))
   (define (handle-absence socket-is-open?)
-    (transition #f
+    (transition: #f : SocketManagerState
       (quit)
       (when socket-is-open?
 	(name-process `(udp-socket-closer ,local-addr)
-	  (spawn (begin (udp-close s)
+	  (spawn: #:parent : SocketManagerState
-			(transition (void) (quit))))))))
+		  #:child : Void
+		  (begin (udp-close s)
+			 (transition: (void) : Void (quit))))))))
 
   (name-process `(udp-socket-manager ,local-addr)
-    (spawn (transition #t
+    (spawn: #: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.
-	      (publisher (handle-mapping local-addr s))
+	      (publisher: SocketManagerState (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))
+	      (publisher: SocketManagerState
+		  (udp-packet-pattern 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))
+	      (subscriber: SocketManagerState
+		  (udp-packet-pattern local-addr any-remote (wild))
 		(match-state socket-is-open?
 		  (on-absence (handle-absence socket-is-open?))
 		  (on-message
@@ -148,10 +220,10 @@
 				(udp-remote-address remote-host remote-port)
 				body)
 		    (begin (udp-send-to s remote-host remote-port body)
-			   (transition socket-is-open?))])))
+			   (transition: socket-is-open? : SocketManagerState))])))
 	      ;; 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))
+	      (subscriber: SocketManagerState (cons (udp-receive!-evt s buffer) (wild))
 		(on-message
 		 [(cons (? evt?) (list (? exact-integer? packet-length)
 				       (? string? remote-host)

examples/chat-paper.rkt

@@ -2,10 +2,12 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (spawn-vm
+ #:debug-name 'listener-vm
  (at-meta-level
   (observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
     (match-conversation (tcp-channel them us _)
-      (on-presence (spawn (chat-session them us)))))))
+      (on-presence (name-process `(,them --> ,us)
+		     (spawn (chat-session them us))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (chat-session them us)

examples/echo-plain.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 ;; Plain Racket version, using (require) instead of #lang marketplace.
 
-(require marketplace/sugar)
+(require marketplace/sugar-untyped)
 (require marketplace/drivers/tcp-bare)
 
 (define (echoer from to)

ground.rkt

@@ -1,19 +1,45 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log.rkt")
+(require "log-typed.rkt")
 (require "process.rkt")
 (require "actions.rkt")
 (require "action-send-message.rkt")
-(require "quasiqueue.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)])
 
 (provide run-ground-vm)
 
-;; run-ground-vm : process-spec -> Void
+(require/typed profile
+	       [profile-thunk ((-> Void) #:custom-key (Option (Pairof
+							       (Continuation-Mark-Keyof Any)
+							       (-> (Listof Any) (Listof Any))))
+			       -> Void)])
+
+(: run-ground-vm : process-spec -> Void)
 (define (run-ground-vm boot)
+  (profile-thunk
+   (lambda ()
+     (profile-thunk (lambda () (run-ground-vm* boot))
+		    #:custom-key (cons marketplace-continuation-mark-key
+				       (lambda: ([vs : (Listof Any)])
+					 (let: loop : (Listof Any) ((vs : (Listof Any) vs))
+					       (if (null? vs)
+						   '(ground)
+						   (cons vs (loop (cdr vs)))))))))
+   #:custom-key #f))
+
+(: run-ground-vm* : process-spec -> Void)
+(define (run-ground-vm* boot)
   (let loop ((state (make-vm boot)))
     (match (run-vm state)
       [(transition state actions)
@@ -31,7 +57,7 @@
 		   "Cannot process meta-actions ~v because no further metalevel exists"
 		   actions)]))
        (define active-events
-	 (endpoint-fold extract-ground-event-subscriptions '() state))
+	 ((inst endpoint-fold (Listof Evt)) extract-ground-event-subscriptions '() state))
        (if (and is-blocking?
 		(null? active-events))
 	   (begin
@@ -42,27 +68,27 @@
 	   (let ((interruptk (apply sync
 				    (if is-blocking?
 					never-evt
-					(wrap-evt always-evt (lambda (dummy) values)))
+					(wrap-evt always-evt (lambda (dummy) (inst values vm))))
 				    active-events)))
 	     (loop (interruptk state))))])))
 
-;; extract-ground-event-subscriptions :
+(: extract-ground-event-subscriptions :
-;;    (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
+   (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
-	     (let ((p wp))
+	     (unwrap-process State vm (p wp)
 	       (let-values
 		   (((p state)
-		     (do-send-message 'publisher (cons evt message) p state)))
+		     (do-send-message 'publisher (cast (cons evt message) Message) p state)))
 		 (if p
-		     (inject-process state p)
+		     (inject-process state (mkProcess p))
 		     state))))))
      (cons (wrap-evt evt evt-handler) acc)]
     [_ acc]))

info.rkt

@@ -1,10 +1,2 @@
 #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.rkt")
+(require "../sugar-untyped.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.rkt")
+	 (all-from-out "../sugar-untyped.rkt")
 	 (all-from-out "../drivers/tcp-bare.rkt")
 	 (all-from-out "../support/spy.rkt")
 	 stateless)

list-utils.rkt

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

log-typed.rkt

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

log-untyped.rkt

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

main.rkt

@@ -1,26 +1,34 @@
-#lang racket/base
+#lang typed/racket/base
-;; Virtualized operating system, this time with presence.
+;; 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 "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
 (require "actions.rkt")
 (require "nested.rkt")
 (require "ground.rkt")
-(require "unify.rkt")
+(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
-(provide (all-from-out "structs.rkt")
+(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?

nested.rkt

@@ -1,17 +1,18 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.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) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
+			 (lambda (k) ((inst k vm) (run-vm (make-vm (make-boot nested-vm-pid)))))))
 	 #f
 	 debug-name))
 

opaque-any.rkt

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

process.rkt

@@ -1,24 +1,27 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
 (require "vm.rkt")
-(require "log.rkt")
+(require "log-typed.rkt")
-(require "quasiqueue.rkt")
+(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
 
 (provide send-to-user
 	 send-to-user*
 	 action-tree->quasiqueue
 	 quit-interruptk
 	 run-ready
-	 notify-route-change-vm)
+	 notify-route-change-vm
+	 marketplace-continuation-mark-key)
+
+(define marketplace-continuation-mark-key (make-continuation-mark-key 'marketplace))
 
 (define-syntax-rule (send-to-user p (e) failure-result enclosed-expr)
   (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)
+  (with-handlers ([exn:fail? (lambda: ([e : Reason])
 			       (if (exn? e)
 				   (marketplace-log 'error "Process ~v(~v):~n~a~n"
 						    debug-name pid (exn-message e))
@@ -26,41 +29,50 @@
 						    debug-name pid e))
 			       failure-result)])
     (marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
-    (define result enclosed-expr)
+    (define result (with-continuation-mark marketplace-continuation-mark-key
+					   (or debug-name pid)
+					   enclosed-expr))
     (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 '()) (t 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!
     (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 (quit #f e))
+    (send-to-user p (e) (transition old-state (ann (quit #f e) (Action State)))
       (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)
+(: notify-route-change-self : (All (SNew)
-;; 				   (process SNew)
+				   (process SNew)
-;; 				   (endpoint SNew)
+				   (endpoint SNew)
-;; 				   (Role -> EndpointEvent)
+				   (Role -> EndpointEvent)
-;; 				   ->
+				   ->
-;; 				   (process SNew))
+				   (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)])
@@ -79,13 +91,13 @@
 				      flow->notification))]
      [else pn])))
 
-;; notify-route-change-process : (All (SOld SNew)
+(: notify-route-change-process : (All (SOld SNew)
-;; 				      (process SOld)
+				      (process SOld)
-;; 				      (process SNew)
+				      (process SNew)
-;; 				      (endpoint SNew)
+				      (endpoint SNew)
-;; 				      (Role -> EndpointEvent)
+				      (Role -> EndpointEvent)
-;; 				      -> (values (process SOld)
+				      -> (values (process SOld)
-;; 						 (process SNew)))
+						 (process SNew))))
 (define (notify-route-change-process po pn en flow->notification)
   (define endpointso (process-endpoints po))
   (for/fold ([po po]
@@ -102,37 +114,39 @@
      [else
       (values po pn)])))
 
-;; invoke-handler-if-visible : (All (State)
+(: invoke-handler-if-visible : (All (State)
-;; 				    (process State)
+				    (process State)
-;; 				    (endpoint State)
+				    (endpoint State)
-;; 				    Role
+				    Role
-;; 				    (Role -> EndpointEvent)
+				    (Role -> EndpointEvent)
-;; 				    ->
+				    ->
-;; 				    (process State))
+				    (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)
+(: notify-route-change-vm : (All (SNew)
-;; 				 (process SNew)
+				 (process SNew)
-;; 				 (endpoint SNew)
+				 (endpoint SNew)
-;; 				 (Role -> EndpointEvent)
+				 (Role -> EndpointEvent)
-;; 				 vm
+				 vm
-;; 				 -> (values (process SNew)
+				 -> (values (process SNew)
-;; 					    vm))
+					    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 ([pn (notify-route-change-self pn en flow->notification)]
+    (for/fold: : (values (process SNew)
-	       [new-processes #hash()])
+			 (HashTable PID Process))
+        ([pn (notify-route-change-self pn en flow->notification)]
+	 [new-processes (ann #hash() (HashTable PID Process))])
 	([pid (in-hash-keys old-processes)])
       (define wp (hash-ref old-processes pid))
       (apply values
-	     (let ((po wp))
+	     (unwrap-process SOld (List (process SNew) (HashTable PID Process)) (po wp)
 	       (let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
-		 (list pn (hash-set new-processes pid po)))))))
+		 (list pn (hash-set new-processes pid (mkProcess po))))))))
   (values final-pn
 	  (struct-copy vm state [processes new-processes])))
 

quasiqueue.rkt

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

roles.rkt

@@ -1,9 +1,14 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
-(require "log.rkt")
+(require "log-typed.rkt")
-(require "unify.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
 
 (provide co-orientations
 	 co-roles
@@ -13,34 +18,34 @@
 	 role-intersection
 	 flow-visible?)
 
-;; co-orientations : Orientation -> (Listof Orientation)
+(: co-orientations : Orientation -> (Listof Orientation))
 (define (co-orientations o)
   (match o
     ['publisher '(subscriber)]
     ['subscriber '(publisher)]))
 
-;; co-roles : Role -> (Listof Role)
+(: co-roles : Role -> (Listof Role))
 (define (co-roles r)
-  (for/list ([co-orientation (co-orientations (role-orientation r))])
+  (for/list: ([co-orientation : 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))
@@ -67,7 +72,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/concepts.scrbl

@@ -82,9 +82,8 @@ 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
+@racket[Transition] structure; the actual Typed Racket type of event
-actions, rather than the explicit pair shown in the approximate type
+handlers is @racket[TrapK], defined in @secref{handler-functions}.
-above. See @secref{handler-functions} for more on handler functions.
 
 @section{What is a VM?}
 

scribblings/drivers.scrbl

@@ -34,9 +34,10 @@ the subscription at the meta-level as well.
 
 @defmodule[marketplace/drivers/tcp-bare]{
 
-This module is included by default in programs using @tt{#lang
+This module is only available for use by untyped Racket processes. It
-marketplace}; see @secref{hashlang-variations} for information on
+is included by default in programs using @tt{#lang marketplace}; see
-other language variants.
+@secref{hashlang-variations} for information on other language
+variants.
 
 @defproc[(tcp-driver) Spawn]{
 
@@ -56,9 +57,9 @@ 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?)]
+@defstruct*[tcp-channel ([source TcpAddress]
-			 [destination (or/c tcp-address? tcp-handle? tcp-listener?)]
+			 [destination TcpAddress]
-			 [subpacket (or/c eof-object? bytes?)]) #:prefab]{
+			 [subpacket TcpSubPacket]) #:prefab]{
 
 A TCP channel represents a section of a unidirectional TCP flow
 appearing on our local "subnet" of the full TCP network, complete with
@@ -66,6 +67,10 @@ source, destination and subpacket. Each TCP connection has two such
 flows: one inbound (remote-to-local) bytestream, and one outbound
 (local-to-remote) bytestream.
 
+}
+
+@deftype[TcpSubPacket (or/c eof-object? bytes?)]{
+
 Packets carried by @racket[tcp-channel] structures are either
 end-of-file objects or raw binary data represented as Racket byte
 vectors.
@@ -74,6 +79,8 @@ vectors.
 
 @subsection{TCP addresses}
 
+@deftype[TcpAddress (or/c tcp-address? tcp-handle? tcp-listener?)]{
+
 A TCP address describes one end of a TCP connection. It can be either
 
 @itemlist[
@@ -82,6 +89,8 @@ A TCP address describes one end of a TCP connection. It can be either
   @item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
 ]
 
+}
+
 @defstruct*[tcp-address ([host string?]
 			 [port (integer-in 0 65535)]) #:prefab]{
 
@@ -100,7 +109,7 @@ a local name for whichever underlying port number ends up being used.
 The @racket[id] must be chosen carefully: it is scoped to the local
 VM, i.e. shared between processes in that VM, so processes must make
 sure not to accidentally clash in handle ID selection. They are also
-used in @racket[tcp-channel] to mean a specific @emph{instance} of a TCP
+used in TcpChannel 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].
 
@@ -194,14 +203,14 @@ where, as for receiving data, the @racket[subpacket] is either
 Not yet documented.
 }
 
-@section{timer}
+@section{timer (typed and untyped)}
 
 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}
+@section{udp (typed and untyped)}
 
 For examples of the use of the UDP driver, see uses of
 @racket[udp-packet] etc. in

scribblings/highlevel.scrbl

@@ -4,7 +4,9 @@
 
 @title[#:tag "high-level-interface"]{High-level interface}
 
-@declare-exporting[#:use-sources (marketplace/sugar)]
+@declare-exporting[#:use-sources (marketplace/sugar-values
+				  marketplace/sugar-untyped
+				  marketplace/sugar-typed)]
 
 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
@@ -15,7 +17,9 @@ interface} of a Unix-like operating system.
 
 @;{
 @defmodulelang*[(marketplace
-		 marketplace/flow-control)]
+		 marketplace/flow-control
+		 marketplace/typed
+		 marketplace/typed/flow-control)]
 }
 
 @defmodulelang[marketplace]
@@ -29,32 +33,44 @@ 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,
+be a variation for Typed Racket, and languages providing greater
-responsibility transfer, and other networking concepts.
+support for flow control, responsibility transfer, and other
+networking concepts. For now, Typed Racket programs must be written as
+@tt{#lang typed/racket} programs using @racket[(require marketplace)]
+and @racket[ground-vm:] explicitly.
 
 @;{
 @itemlist[
 
-  @item{@racket[marketplace] is for ordinary Racket programs, and uses
+  @item{@racket[marketplace] is for @emph{untyped} programs, and uses
   the @secref{tcp-bare} TCP driver;}
 
   @item{@racket[marketplace/flow-control] is like
   @racket[marketplace], but uses the flow-controlled @secref{tcp}
   driver;}
 
+  @item{@racket[marketplace/typed] is like @racket[marketplace], but
+  for @emph{typed} programs;}
+
+  @item{@racket[marketplace/typed/flow-control] is like
+  @racket[marketplace/flow-control], but for typed programs.}
+
 ]
 }
 
 @section{Using Marketplace as a library}
 
-@defmodule*[(marketplace/sugar)
+@defmodule*[(marketplace/sugar-untyped
-	    #:use-sources (marketplace/sugar)]
+	     marketplace/sugar-typed)
+	    #:use-sources (marketplace/sugar-values
+			   marketplace/sugar-untyped
+			   marketplace/sugar-typed)]
 
 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
+Such programs need to use @racket[ground-vm]/@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
@@ -67,48 +83,65 @@ start any drivers they need; for example, the file
                (on-presence (spawn (echoer from to))))))
 ]
 
-@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)
+@deftogether[(
+@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)]
+@defform[(ground-vm: maybe-boot-pid-binding maybe-typed-initial-state initial-action ...)
 	 #: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)]]{
+	  (maybe-typed-initial-state (code:line)
+	  		       	     (code:line #:initial-state expr : type))
+	  (initial-action expr)]]
+)]{
 
-Starts the ground VM. If @racket[#:boot-pid] is specified, the given
+Starts the ground VM, in untyped and typed programs, respectively. If
-identifier is bound within the form to the PID of the @emph{primordial
+@racket[#:boot-pid] is specified, the given identifier is bound within
-process} that performs the initial actions. If
+the form to the PID of the @emph{primordial process} that performs the
-@racket[#:initial-state] is specified, it is used as the initial state
+initial actions. If @racket[#:initial-state] is specified (with a
-for the primordial process; if it is not supplied, the primordial
+type, for @racket[ground-vm:]), it is used as the initial state for
-process is given @racket[(void)] as its initial state.
+the primordial process; if it is not supplied, the primordial process
+is given @racket[(void)] as its initial state (and @racket[Void] as
+its state type).
 
 }
 
 @section[#:tag "constructing-transitions"]{Constructing transitions}
 
 @declare-exporting[#:use-sources (marketplace
-				  marketplace/sugar)]
+				  marketplace/sugar-values
+				  marketplace/sugar-untyped
+				  marketplace/sugar-typed)]
 
 @deftogether[(
 @defform[(transition new-state action-tree ...)]
+@defform[(transition: new-state : State action-tree ...)]
 @defform[(transition/no-state action-tree ...)]
 )]{
 
-Each of these forms produces a @racket[transition] structure.
+Each of these forms produces a @racket[Transition] structure. The
+first is for untyped code, the second for typed code (where the
+mandatory @racket[State] is the type of the transitioning process's
+private state), and the third for either.
 
-Each @racket[action-tree] must be an @tech{action tree}.
+Each @racket[action-tree] must be an @racket[(ActionTree State)].
-It's fine to include @emph{no} action trees, in which case the
+
+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)]
+In the case of @racket[transition/no-state], the type @racket[Void]
-is used for the process state. @racket[transition/no-state] is useful
+and value @racket[(void)] is used for the process state.
-for processes that are stateless other than the implicit state of
+@racket[transition/no-state] is useful for processes that are
-their endpoints.
+stateless other than the implicit state of their endpoints.
 
 }
 
-@defstruct*[transition ([state State] [actions action-tree?]) #:transparent]{
+@deftogether[(
+@defstruct*[transition ([state State] [actions (ActionTree State)]) #:transparent]
+@deftype[(Transition State) (transition State)]
+)]{
 
 A transition structure. The @racket[transition-state] field is the new
 private state the process will have after the transition is applied,
@@ -117,23 +150,16 @@ performed by the VM in order to apply the transition.
 
 }
 
-@defproc[(action-tree? [value any/c]) boolean?]{
+@deftogether[(
+@deftype[(ActionTree State) (Constreeof (Action State))]
+@deftype[(Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null))]
+)]{
 
-Predicate that recognises an @deftech{action tree}. An action tree is
+An action-tree is a @deftech{cons-tree} of @racket[Action]s. When
-either
+performing actions, a VM will traverse an action-tree in left-to-right
+order.
 
-@itemlist[
+@racket['()], @racket[(void)], and @racket[#f] may also be present in
-	  @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.
 
@@ -175,9 +201,10 @@ at all" in a transition:
 
 }
 
-@defproc[(sequence-actions [initial-transition transition?]
+@defproc[(sequence-actions [initial-transition (Transition State)]
-			   [item (or/c action-tree? (any/c -> transition?))]
+			   [item (U (ActionTree State)
-			   ...) transition?]{
+				    (State -> (Transition State)))]
+			   ...) (Transition State)]{
 
 Returns a transition formed from the @racket[initial-transition]
 extended with new actions, possibly updating its carried state. Each
@@ -218,30 +245,44 @@ collection of macros helps streamline endpoint setup.
 
 @deftogether[(
 @defform[(publisher topic handler ...)]
+@defform[(publisher: State topic handler ...)]
 @defform[(subscriber topic handler ...)]
+@defform[(subscriber: State topic handler ...)]
 @defform[(observe-subscribers topic handler ...)]
+@defform[(observe-subscribers: State topic handler ...)]
 @defform[(observe-publishers topic handler ...)]
+@defform[(observe-publishers: State topic handler ...)]
 @defform[(observe-subscribers/everything topic handler ...)]
+@defform[(observe-subscribers/everything: State topic handler ...)]
 @defform[(observe-publishers/everything topic handler ...)]
+@defform[(observe-publishers/everything: State topic handler ...)]
 @defform[(build-endpoint pre-eid role handler ...)]
+@defform[(build-endpoint: State pre-eid role handler ...)]
 )]{
 
 The many variations on the core
-@racket[build-endpoint] form exist to give
+@racket[build-endpoint]/@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.
+mandatory part is the topic, unless you're using Typed Racket, in
+which case the process state type must also be specified.
 
 For example, a minimal endpoint subscribing to all messages would be:
 
 @racketblock[(subscriber ?)]
 
+or in Typed Racket, for a process with @racket[Integer] as its process
+state type,
+
+@racketblock[(subscriber: Integer ?)]
+
 A minimal publishing endpoint would be:
 
-@racketblock[(publisher ?)]
+@racketblock[(publisher ?)
+	     (publisher: Integer ?)]
 
 While topic patterns are ordinary Racket data with embedded @racket[?]
 wildcards (see @secref{messages-and-topics}), all the other patterns
@@ -279,7 +320,7 @@ 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.
+@racket[ActionTree]s.
 
 This way, simple handlers that do not need to examine the process
 state, and simply act in response to whichever event triggered them,
@@ -442,8 +483,9 @@ dynamically:
 
 @itemlist[
 
-  @item{@racket[publisher] and @racket[subscriber] are for ordinary
+  @item{@racket[publisher] and @racket[subscriber] (and typed
-@emph{participation} in conversations;}
+variations ending in @tt{:}) 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}
@@ -468,7 +510,7 @@ but as an observer, the code should declare the roles being observed.
 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]{
+@defproc[(name-endpoint [id Any] [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
@@ -530,7 +572,15 @@ Equivalent to @racket[(send-message body 'subscriber)].
 @defform[(spawn maybe-pid-binding boot-expr)]
 @defform[(spawn/continue maybe-pid-binding
 			 #:parent parent-state-pattern k-expr
-			 #:child boot-expr)
+			 #:child boot-expr)]
+@defform[#:literals (:)
+         (spawn: maybe-pid-binding
+		 #:parent : ParentStateType
+		 #:child : ChildStateType boot-expr)]
+@defform[#:literals (:)
+         (spawn/continue: maybe-pid-binding
+			  #:parent parent-state-pattern : ParentStateType k-expr
+			  #:child : ChildStateType boot-expr)
 	 #:grammar
 	 [(maybe-pid-binding (code:line)
 			     (code:line #:pid identifier))
@@ -546,11 +596,15 @@ 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],
+The @racket[spawn/continue] and @racket[spawn/continue:] variations
-which will run in the parent process after the child process has been
+include a @racket[k-expr], which will run in the parent process after
-created. Note that @racket[k-expr] must return a @racket[transition],
+the child process has been created. Note that @racket[k-expr] must
-since @racket[parent-state-pattern] is always supplied for these
+return a @racket[Transition], since @racket[parent-state-pattern] is
-variations.
+always supplied for these variations.
+
+In Typed Racket, for type system reasons, @racket[spawn:] and
+@racket[spawn/continue:] require @racket[ParentStateType] to be
+supplied as well as @racket[ChildStateType].
 
 }
 
@@ -587,7 +641,11 @@ itself.
 
 @section{Cooperative scheduling}
 
-@defform[(yield state-pattern k-expr)]{
+@deftogether[(
+@defform[(yield state-pattern k-expr)]
+@defform[#:literals (:)
+	 (yield: state-pattern : State 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
@@ -595,16 +653,23 @@ 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].
+@racket[k-expr] must evaluate to a @racket[Transition].
 
 }
 
 @section{Creating nested VMs}
 
+@deftogether[(
 @defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
 		   maybe-initial-state
 		   maybe-debug-name
-		   boot-action-expr ...)
+		   boot-action-expr ...)]
+@defform[#:literals (:)
+	 (spawn-vm: : ParentStateType
+		    maybe-vm-pid-binding maybe-boot-pid-binding
+		    maybe-typed-initial-state
+		    maybe-debug-name
+		    boot-action-expr ...)
 	 #:grammar
 	 [(maybe-vm-pid-binding (code:line)
 				(code:line #:vm-pid identifier))
@@ -612,9 +677,12 @@ The state of the yielding process will be matched against
 				  (code:line #:boot-pid identifier))
 	  (maybe-initial-state (code:line)
 			       (code:line #:initial-state expr))
+	  (maybe-typed-initial-state (code:line)
+				     (code:line #:initial-state expr : StateType))
 	  (maybe-debug-name (code:line)
 			    (code:line #:debug-name expr))
-	  (boot-action-expr expr)]]{
+	  (boot-action-expr expr)]]
+)]{
 
 Results in a @racket[spawn] action that starts a nested VM. The
 primordial process in the new VM executes the boot-actions with the
@@ -631,7 +699,10 @@ primordial process in the new VM.
 
 @section{Relaying across layers}
 
-@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]{
+@deftogether[(
+@defform[(at-meta-level: StateType preaction ...)]
+@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
@@ -640,9 +711,9 @@ 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
+using @racket[at-meta-level] (or @racket[at-meta-level:] in typed
-action to make it apply at the level of the acting process's VM's
+code) to wrap an action @emph{level-shifts} the action to make it
-container instead.
+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

scribblings/lowlevel.scrbl

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

scribblings/management-and-monitoring.scrbl

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

scribblings/prelude.inc

@@ -12,7 +12,21 @@
 	 (for-label typed/racket/base))
 
 (require (for-label (only-in marketplace/drivers/tcp-bare tcp)
-		    marketplace/sugar))
+		    (except-in marketplace/sugar-untyped
+			       name-endpoint
+			       name-process
+			       transition/no-state)
+		    (except-in marketplace/sugar-typed
+			       ?
+			       let-fresh
+			       match-state
+			       match-orientation
+			       match-conversation
+			       match-interest-type
+			       match-reason
+			       on-presence
+			       on-absence
+			       on-message)))
 
 ;; TODO: make it display "=" instead of ":" connecting the defined
 ;; type to the definition.

structs.rkt

@@ -1,96 +0,0 @@
-#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-endpoints-support.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+
+(require (for-syntax racket/base))
+(require "support/dsl-untyped.rkt")
+
+;; We define and provide these here so that they can be used by both
+;; typed and untyped contexts. If we define them separately in untyped
+;; and typed contexts, then TR's wrapping of provided identifiers
+;; interferes with literal comparison in our macros. See also
+;; definition and use of the file support/dsl-typed.rkt in git rev
+;; b477046.
+
+(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])

sugar-endpoints-typed.rkt

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

sugar-endpoints-untyped.rkt

@@ -4,27 +4,12 @@
 (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")
+(require "sugar-endpoints-support.rkt")
-
-	 transition
-	 delete-endpoint
-	 send-message
-	 send-feedback
-	 quit
-	 sequence-actions
-	 (rename-out [core:wild wild])
 
+(provide (all-from-out "sugar-endpoints-support.rkt")
 	 name-endpoint
 	 let-fresh
 	 observe-subscribers
@@ -33,71 +18,7 @@
 	 observe-publishers/everything
 	 publisher
 	 subscriber
-	 build-endpoint
+	 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
@@ -294,88 +215,7 @@
 				  (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)

sugar-typed.rkt

@@ -0,0 +1,133 @@
+#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")
+(require "sugar-endpoints-typed.rkt")
+
+(provide (all-from-out "sugar-values.rkt")
+	 (all-from-out "sugar-endpoints-typed.rkt")
+	 (all-from-out "main.rkt")
+	 ?
+	 transition:
+	 transition/no-state
+	 spawn:
+	 spawn/continue:
+	 name-process
+	 yield:
+	 at-meta-level:
+	 spawn-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 spawn:
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
+	  #:parent (~literal :) ParentState
+	  #:child (~literal :) State exp)
+       #`((inst core:spawn ParentState)
+	  (core:process-spec (lambda (pid) (lambda (k) ((inst k State) 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 (~literal :) ParentState parent-k-exp
+	  #:child (~literal :) State exp)
+       #`((inst core:spawn ParentState)
+	  (core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
+	  (lambda (pid) (lambda: ([parent-state : ParentState])
+			  (match parent-state [parent-state-pattern parent-k-exp])))
+	  #f)])))
+
+(: name-process : (All (State) Any (core:Spawn State) -> (core:Spawn State)))
+(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 : State exp)
+       #'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))])))
+
+(define-syntax at-meta-level:
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ State)
+       #''()]
+      [(_ State preaction)
+       #'((inst core:at-meta-level State) preaction)]
+      [(_ State preaction ...)
+       #'(list ((inst core:at-meta-level State) preaction) ...)])))
+
+(define-syntax spawn-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 1)
+;;; End:

sugar-untyped.rkt

@@ -0,0 +1,113 @@
+#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")
+(require "sugar-endpoints-untyped.rkt")
+
+(provide (all-from-out "sugar-values.rkt")
+	 (all-from-out "sugar-endpoints-untyped.rkt")
+	 (all-from-out "main.rkt")
+	 ?
+	 transition/no-state
+	 spawn
+	 spawn/continue
+	 name-process
+	 yield
+	 at-meta-level
+	 spawn-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 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 'name-process 'scheme-indent-function 1)
+;;; eval: (put 'yield 'scheme-indent-function 1)
+;;; End:

sugar-values.rkt

@@ -0,0 +1,80 @@
+#lang typed/racket/base
+
+(require racket/match)
+(require (prefix-in core: "main.rkt"))
+
+(provide transition
+	 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))
+
+(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)]))])))
+
+;;; Local Variables:
+;;; eval: (put 'sequence-actions 'scheme-indent-function 1)
+;;; End:

support/debug.rkt

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

support/event.rkt

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

support/gui.rkt

@@ -19,7 +19,7 @@
 
 (require racket/pretty)
 
-(require (prefix-in core: "../structs.rkt")
+(require (prefix-in core: "../types.rkt")
 	 (prefix-in core: "../vm.rkt"))
 
 (provide open-debugger)
@@ -55,9 +55,20 @@
 	 [name name]
 	 [from-vm to-debugger]
 	 [to-vm from-debugger]))
-  (lambda (v)
+  (wrap/unwrapper
-    (channel-put to-debugger v)
+   (lambda (v)
-    (channel-get from-debugger)))
+     (channel-put to-debugger v)
+     (channel-get from-debugger))))
+
+;; This is utterly vile.
+(define (wrap/unwrapper thunk)
+  (local-require racket/unsafe/ops)
+  (lambda (wrapped-val)
+    ;; (pretty-print `(wrapped-val ,wrapped-val))
+    (define inner (unsafe-struct-ref wrapped-val 0))
+    ;; (pretty-print `(inner ,inner))
+    (unsafe-struct-set! wrapped-val 0 (thunk inner))
+    wrapped-val))
 
 (define sane-tab-panel%
   (class tab-panel%
@@ -70,13 +81,6 @@
 	      (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%
 
@@ -303,7 +307,7 @@
       (send events set-data n current-historical-moment)
       (send events set-string n dir 1)
       (send events set-string n type 2)
-      (send events set-string n (string->label-string (~a detail)) 3)
+      (send events set-string n (~a detail) 3)
       (define current-selection (send events get-selection))
       (when (or (not current-selection) (= current-selection (- n 1)))
 	(send events set-first-visible-item n)

support/pseudo-substruct.rkt

@@ -0,0 +1,18 @@
+#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 (... ...))])))))

support/spy.rkt

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

test-struct-map-typed.rkt

@@ -0,0 +1,12 @@
+#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))

tr-struct-copy.rkt

@@ -0,0 +1,166 @@
+#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)))))))])))

types.rkt

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

vm.rkt

@@ -1,18 +1,22 @@
-#lang racket/base
+#lang typed/racket/base
 
 (require racket/match)
-(require "structs.rkt")
+(require "types.rkt")
 (require "roles.rkt")
-(require "quasiqueue.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
+	 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
@@ -22,53 +26,79 @@
 	 process-map
 	 endpoint-fold)
 
-(struct vm (processes ;; (HashTable PID Process)
+(struct: vm ([processes : (HashTable PID Process)]
-	    next-process-id ;; PID
+	     [next-process-id : PID])
-	    )
+	 #:transparent)
-	#:transparent)
 
-(struct process (debug-name ;; Any
+(struct: (State)
-		 pid ;; PID
+	 process ([debug-name : Any]
-		 state ;; State
+		  [pid : PID]
-		 spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
+		  [state : State]
-		 endpoints ;; (HashTable PreEID (endpoint State))
+		  [spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm
-		 meta-endpoints ;; (HashTable PreEID (endpoint State))
+		  [endpoints : (HashTable PreEID (endpoint State))]
-		 pending-actions ;; (QuasiQueue (Action State))
+		  [meta-endpoints : (HashTable PreEID (endpoint State))]
-		 )
+		  [pending-actions : (QuasiQueue (Action State))])
-	#:transparent)
+	 #:transparent)
 
-(struct endpoint (id ;; eid
+(struct: (State)
-		  role ;; role
+	 endpoint ([id : eid]
-		  handler ;; (Handler State)
+		   [role : role]
-		  )
+		   [handler : (Handler State)])
-	#:transparent)
+	 #:transparent)
 
-(struct eid (pid ;; PID
+(struct: eid ([pid : PID]
-	     pre-eid ;; PreEID
+	      [pre-eid : PreEID])
-	     )
+	 #:transparent)
-	#:transparent)
+
+(define-type Process		(All (R) (CoProcess R) -> R))
+(define-type (CoProcess R)	(All (State) (process State) -> R))
+
+(: mkProcess : (All (State) ((CoProcess Process) State)))
+;; A kind of identity function, taking the components of a process to
+;; a process.
+(define (mkProcess p)
+  (lambda (k) ((inst k State) p)))
+
+(: Process-pid : Process -> PID)
+(define (Process-pid wp) ((inst wp PID) process-pid))
+
+;; Unwraps a process. Result is the type of the result of the
+;; expression; State is a type variable to be bound to the process's
+;; private state type. p is to be bound to the unwrapped process; wp
+;; is the expression producing the wrapped process. body... are the
+;; forms computing a value of type Result.
+(define-syntax-rule (unwrap-process State Result (p wp) body ...)
+  (let ()
+    (: coproc : (All (State) (process State) -> Result))
+    (define (coproc p)
+      body ...)
+    ((inst wp Result) coproc)))
 
 ;;---------------------------------------------------------------------------
 
-;; make-vm : process-spec -> vm
+(: make-vm : process-spec -> vm)
 (define (make-vm boot)
-  (define primordial (process '#:primordial
+  (define primordial (mkProcess ((inst process Void)
-			      -1
+				 '#:primordial
-			      (void)
+				 -1
-			      (list)
+				 (void)
-			      #hash()
+				 (list)
-			      #hash()
+				 #hash()
-			      (quasiqueue (spawn boot #f '#:boot-process))))
+				 #hash()
-  (vm (hash-set #hash() (process-pid primordial) primordial) 0))
+				 (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
+(: inject-process : vm Process -> vm)
 (define (inject-process state wp)
-  (struct-copy vm state [processes (hash-set (vm-processes state) (process-pid wp) wp)]))
+  (struct-copy vm state [processes (hash-set (vm-processes state) (Process-pid wp) wp)]))
 
-;; always-false : -> False
+(: always-false : -> False)
 (define (always-false) #f)
 
-;; extract-process : vm PID -> (values vm (Option Process))
+(: 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
@@ -76,28 +106,29 @@
 	      state)
 	  wp))
 
-;; reset-pending-actions : (All (State) (process State) -> (process State))
+(: reset-pending-actions : (All (State) (process State) -> (process State)))
 (define (reset-pending-actions p)
-  (struct-copy process p [pending-actions (empty-quasiqueue)]))
+  (struct-copy process p [pending-actions ((inst empty-quasiqueue (Action State)))]))
 
-;; process-map : (All (State) (process State) -> (process State)) vm -> vm
+(: 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))))))
+	  (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)
+(: 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))])
+	  (unwrap-process State A (p wp)
-	    (define ep (hash-ref (process-endpoints wp) pre-eid))
+	    (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))])
-	    (f wp ep seed))))))
+	      (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)