From da7851d45183f534371992a5b4b7b97a9de28fdb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 6 Aug 2014 12:16:50 -0700 Subject: [PATCH] First pass at converting to untyped --- action-add-endpoint.rkt | 11 +- action-delete-endpoint.rkt | 26 +-- action-quit.rkt | 21 +- action-send-message.rkt | 14 +- action-spawn.rkt | 46 ++-- actions.rkt | 83 ++++--- drivers/event-relay.rkt | 43 ++-- drivers/tcp-bare-with-ground.rkt | 3 +- drivers/tcp-bare.rkt | 2 +- drivers/tcp.rkt | 3 +- drivers/timer-untyped.rkt | 13 -- drivers/timer.rkt | 179 +++++--------- drivers/udp-untyped.rkt | 21 -- drivers/udp.rkt | 200 +++++----------- examples/echo-plain.rkt | 2 +- ground.rkt | 33 ++- lang/base.rkt | 4 +- list-utils.rkt | 4 +- log-typed.rkt | 17 -- log-untyped.rkt => log.rkt | 1 - main.rkt | 18 +- nested.rkt | 9 +- opaque-any.rkt | 9 - process.rkt | 93 ++++---- quasiqueue.rkt | 32 ++- roles.rkt | 29 +-- scribblings/highlevel.scrbl | 15 +- scribblings/lowlevel.scrbl | 12 +- scribblings/management-and-monitoring.scrbl | 5 +- scribblings/prelude.inc | 16 +- structs.rkt | 96 ++++++++ sugar-endpoints-support.rkt | 21 -- sugar-endpoints-typed.rkt | 247 -------------------- sugar-typed.rkt | 133 ----------- sugar-untyped.rkt | 113 --------- sugar-values.rkt | 80 ------- sugar-endpoints-untyped.rkt => sugar.rkt | 166 ++++++++++++- support/debug.rkt | 96 ++++---- support/event.rkt | 7 - support/gui.rkt | 2 +- support/pseudo-substruct.rkt | 18 -- support/spy.rkt | 44 ++-- test-struct-map-typed.rkt | 12 - tr-struct-copy.rkt | 166 ------------- types.rkt | 119 ---------- vm.rkt | 127 ++++------ 46 files changed, 722 insertions(+), 1689 deletions(-) delete mode 100644 drivers/timer-untyped.rkt delete mode 100644 drivers/udp-untyped.rkt delete mode 100644 log-typed.rkt rename log-untyped.rkt => log.rkt (96%) delete mode 100644 opaque-any.rkt create mode 100644 structs.rkt delete mode 100644 sugar-endpoints-support.rkt delete mode 100644 sugar-endpoints-typed.rkt delete mode 100644 sugar-typed.rkt delete mode 100644 sugar-untyped.rkt delete mode 100644 sugar-values.rkt rename sugar-endpoints-untyped.rkt => sugar.rkt (59%) delete mode 100644 support/event.rkt delete mode 100644 support/pseudo-substruct.rkt delete mode 100644 test-struct-map-typed.rkt delete mode 100644 tr-struct-copy.rkt delete mode 100644 types.rkt diff --git a/action-add-endpoint.rkt b/action-add-endpoint.rkt index f64ab59..5397a10 100644 --- a/action-add-endpoint.rkt +++ b/action-add-endpoint.rkt @@ -1,16 +1,15 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") (require "process.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (provide do-add-endpoint) -(: do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm - -> (values (Option (process State)) vm))) +;; do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm +;; -> (values (Option (process State)) vm)) (define (do-add-endpoint pre-eid role h p state) (define new-eid (eid (process-pid p) pre-eid)) (define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f))) @@ -35,7 +34,7 @@ state))) (values p state)))) -(: install-endpoint : (All (State) (process State) (endpoint State) -> (process State))) +;; install-endpoint : (All (State) (process State) (endpoint State) -> (process State)) (define (install-endpoint p ep) (define pre-eid (eid-pre-eid (endpoint-id ep))) (struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)])) diff --git a/action-delete-endpoint.rkt b/action-delete-endpoint.rkt index 6987242..4624938 100644 --- a/action-delete-endpoint.rkt +++ b/action-delete-endpoint.rkt @@ -1,46 +1,44 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") (require "process.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "quasiqueue.rkt") (provide do-delete-endpoint delete-all-endpoints) -(: do-delete-endpoint : (All (State) PreEID Reason (process State) vm - -> (values (process State) vm))) +;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm +;; -> (values (process State) vm)) (define (do-delete-endpoint pre-eid reason p state) (cond [(hash-has-key? (process-endpoints p) pre-eid) (define old-endpoint (hash-ref (process-endpoints p) pre-eid)) (let-values (((p state) (notify-route-change-vm (remove-endpoint p old-endpoint) old-endpoint - (lambda: ([t : Role]) (absence-event t reason)) + (lambda (t) (absence-event t reason)) state))) (values p state))] [else (values p state)])) -(: remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))) +;; remove-endpoint : (All (State) (process State) (endpoint State) -> (process State)) (define (remove-endpoint p ep) (define pre-eid (eid-pre-eid (endpoint-id ep))) (struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)])) -(: delete-all-endpoints : (All (State) Reason (process State) vm - -> (values (process State) vm (QuasiQueue (Action vm))))) +;; delete-all-endpoints : (All (State) Reason (process State) vm +;; -> (values (process State) vm (QuasiQueue (Action vm)))) (define (delete-all-endpoints reason p state) (let-values (((p state) - (for/fold: : (values (process State) vm) - ([p p] [state state]) + (for/fold ([p p] [state state]) ([pre-eid (in-hash-keys (process-endpoints p))]) (do-delete-endpoint pre-eid reason p state)))) (values p state (list->quasiqueue - (map (lambda (#{pre-eid : PreEID}) - (delete-endpoint (cast (eid (process-pid p) pre-eid) PreEID) - reason)) + (map (lambda (pre-eid) + (delete-endpoint (eid (process-pid p) pre-eid) reason)) (hash-keys (process-meta-endpoints p))))))) diff --git a/action-quit.rkt b/action-quit.rkt index 2125ff7..523aa88 100644 --- a/action-quit.rkt +++ b/action-quit.rkt @@ -1,24 +1,23 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") -(require "log-typed.rkt") +(require "log.rkt") (require "process.rkt") (require "action-delete-endpoint.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "quasiqueue.rkt") -(require/typed web-server/private/util - [exn->string (exn -> String)]) +(require (only-in web-server/private/util exn->string)) (provide do-quit) -(: do-quit : (All (State) PID Reason (process State) vm - -> (values (Option (process State)) vm (QuasiQueue (Action vm))))) +;; do-quit : (All (State) PID Reason (process State) vm +;; -> (values (Option (process State)) vm (QuasiQueue (Action vm)))) (define (do-quit killed-pid reason p state) - (: log-quit : (All (KilledState) (process KilledState) -> Void)) + ;; log-quit : (All (KilledState) (process KilledState) -> Void) (define (log-quit p) (marketplace-log (if reason 'warning 'info) "PID ~v (~a) quits with reason: ~a" @@ -36,9 +35,7 @@ (if (not maybe-killed-wp) (values p state (empty-quasiqueue)) (apply values - (unwrap-process KilledState - (List (Option (process State)) vm (QuasiQueue (Action vm))) - (killed-p maybe-killed-wp) + (let ((killed-p maybe-killed-wp)) (log-quit killed-p) (let-values (((killed-p state meta-actions) (delete-all-endpoints reason killed-p state))) diff --git a/action-send-message.rkt b/action-send-message.rkt index 9089b8f..e59e21a 100644 --- a/action-send-message.rkt +++ b/action-send-message.rkt @@ -1,24 +1,22 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") (require "process.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (provide do-send-message) -(: do-send-message : (All (State) Orientation Message (process State) vm -> - (Values (Option (process State)) vm))) +;; do-send-message : (All (State) Orientation Message (process State) vm -> +;; (Values (Option (process State)) vm)) (define (do-send-message orientation body sender-p state) (define message-role (role orientation body 'participant)) - (: send-to-process : (All (State) (process State) -> (process State))) + ;; send-to-process : (All (State) (process State) -> (process State)) (define (send-to-process p) (define endpoints (process-endpoints p)) - (for/fold: : (process State) ([p p]) - ([eid (in-hash-keys endpoints)]) + (for/fold ([p p]) ([eid (in-hash-keys endpoints)]) (define e (hash-ref endpoints eid)) (cond [(role-intersection message-role (endpoint-role e)) diff --git a/action-spawn.rkt b/action-spawn.rkt index b7566c6..8442ab4 100644 --- a/action-spawn.rkt +++ b/action-spawn.rkt @@ -1,46 +1,44 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") -(require "log-typed.rkt") +(require "log.rkt") (require "process.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (provide do-spawn) -(: do-spawn : (All (OldState) - process-spec - (Option (PID -> (InterruptK OldState))) - (process OldState) - Any - vm - -> (Values (Option (process OldState)) vm))) +;; do-spawn : (All (OldState) +;; process-spec +;; (Option (PID -> (InterruptK OldState))) +;; (process OldState) +;; Any +;; vm +;; -> (Values (Option (process OldState)) vm)) (define (do-spawn spec parent-k p debug-name state) (define new-pid (vm-next-process-id state)) (marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name) - (: new-cotransition : CoTransition) + ;; new-cotransition : CoTransition (define new-cotransition (send-to-user* debug-name new-pid (e) (co-quit e) ((process-spec-boot spec) new-pid))) - (: co-quit : Reason -> CoTransition) + ;; co-quit : Reason -> CoTransition (define ((co-quit e) k) - ((inst k False) (transition #f (quit #f e)))) - (: transition-accepter : (All (NewState) (Transition NewState) -> Process)) + (k (transition #f (quit #f e)))) + ;; transition-accepter : (All (NewState) (Transition NewState) -> Process) (define (transition-accepter t) (match-define (transition initial-state initial-actions) t) - (mkProcess ((inst process NewState) - debug-name - new-pid - initial-state - '() - #hash() - #hash() - (action-tree->quasiqueue initial-actions)))) + (process debug-name + new-pid + initial-state + '() + #hash() + #hash() + (action-tree->quasiqueue initial-actions))) (let ((new-process (send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e))) - ((inst new-cotransition Process) transition-accepter)))) + (new-cotransition transition-accepter)))) (values (if parent-k (run-ready p (send-to-user p (e) (quit-interruptk e) (parent-k new-pid))) diff --git a/actions.rkt b/actions.rkt index 7cb7693..224aff3 100644 --- a/actions.rkt +++ b/actions.rkt @@ -1,10 +1,10 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") -(require "log-typed.rkt") +(require "log.rkt") (require "process.rkt") (require "action-add-endpoint.rkt") (require "action-delete-endpoint.rkt") @@ -12,18 +12,17 @@ (require "action-spawn.rkt") (require "action-quit.rkt") (require "list-utils.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "quasiqueue.rkt") (provide run-vm) -(: dump-state : vm -> Any) +;; dump-state : vm -> Any (define (dump-state state) `(vm (next-pid ,(vm-next-process-id state)) - (processes ,@(for/fold: : Any - ([acc '()]) + (processes ,@(for/fold ([acc '()]) ([pid (in-hash-keys (vm-processes state))]) (cons (list pid (let ((wp (hash-ref (vm-processes state) pid))) - (unwrap-process State Any (p wp) + (let ((p wp)) (list (match (process-state p) [(? vm? v) (dump-state v)] [v v]) @@ -32,16 +31,16 @@ (process-meta-endpoints p) (process-pending-actions p))))) acc))))) -(: run-vm : vm -> (Transition vm)) +;; run-vm : vm -> (Transition vm) (define (run-vm state) ;; for each pid, ;; extract the corresponding process. ;; run through its work items, collecting external actions. ;; put the process back. ;; return the new state and the external actions - (let next-process ((remaining-pids ((inst hash-keys PID Process) (vm-processes state))) + (let next-process ((remaining-pids (hash-keys (vm-processes state))) (state state) - (external-actions ((inst empty-quasiqueue (Action vm))))) + (external-actions (empty-quasiqueue))) (match remaining-pids ['() (let ((state (collect-dead-processes state)) @@ -54,7 +53,7 @@ (let-values (((state wp) (extract-process state pid))) (if (not wp) (next-process remaining-pids state external-actions) - (unwrap-process State (transition vm) (p wp) + (let ((p wp)) (let next-action ([remaining-actions (quasiqueue->list (process-pending-actions p))] [p (reset-pending-actions p)] @@ -63,7 +62,7 @@ (match remaining-actions ['() (next-process remaining-pids - (inject-process state (mkProcess p)) + (inject-process state p) external-actions)] [(cons action remaining-actions) (marketplace-log 'debug @@ -84,20 +83,19 @@ (quasiqueue-append external-actions new-external-actions))))])))))]))) -(: collect-dead-processes : vm -> vm) +;; collect-dead-processes : vm -> vm (define (collect-dead-processes state) - (: process-alive? : (All (State) (process State) -> Boolean)) + ;; process-alive? : (All (State) (process State) -> Boolean) (define (process-alive? p) (or (not (null? (process-spawn-ks p))) (positive? (hash-count (process-endpoints p))) (positive? (hash-count (process-meta-endpoints p))) (not (quasiqueue-empty? (process-pending-actions p))))) (struct-copy vm state - [processes (for/fold: : (HashTable PID Process) - ([processes (ann #hash() (HashTable PID Process))]) + [processes (for/fold ([processes #hash()]) ([pid (in-hash-keys (vm-processes state))]) (define wp (hash-ref (vm-processes state) pid)) - (unwrap-process State (HashTable PID Process) (p wp) + (let ((p wp)) (if (process-alive? p) (hash-set processes pid wp) (begin (marketplace-log 'info @@ -106,20 +104,21 @@ (process-debug-name p)) processes))))])) -(: vm-idle? : vm -> Boolean) +;; vm-idle? : vm -> Boolean +;; TODO: simplify (define (vm-idle? state) - (andmap (lambda (#{pid : PID}) + (andmap (lambda (pid) (define wp (hash-ref (vm-processes state) pid)) - (unwrap-process State Boolean (p wp) + (let ((p wp)) (quasiqueue-empty? (process-pending-actions p)))) (hash-keys (vm-processes state)))) -(: perform-action : (All (State) (Action State) (process State) vm - -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))) +;; perform-action : (All (State) (Action State) (process State) vm +;; -> (Values (Option (process State)) vm (QuasiQueue (Action vm)))) (define (perform-action action p state) (match action [(at-meta-level preaction) - ((inst transform-meta-action State) preaction p state)] + (transform-meta-action preaction p state)] [(yield k) (let ((p (run-ready p k))) (values p state (empty-quasiqueue)))] @@ -140,39 +139,39 @@ new-state (empty-quasiqueue))])) -(: wrap-trapk : eid -> (Handler vm)) +;; wrap-trapk : eid -> (Handler vm) (define (((wrap-trapk target-eid) event) state) (match-define (eid pid pre-eid) target-eid) (run-vm (let-values (((state wp) (extract-process state pid))) (if (not wp) state - (unwrap-process State vm (p wp) + (let ((p wp)) (define ep (hash-ref (process-meta-endpoints p) pre-eid always-false)) (if (not ep) - (inject-process state (mkProcess p)) + (inject-process state p) (let ((p (run-ready p (send-to-user p (e) (quit-interruptk e) ((endpoint-handler ep) event))))) - (inject-process state (mkProcess p))))))))) + (inject-process state p)))))))) -(: dispatch-spawn-k : PID Integer -> (TrapK PID vm)) +;; dispatch-spawn-k : PID Integer -> (TrapK PID vm) (define (((dispatch-spawn-k pid spawn-k-id) new-pid) state) (run-vm (let-values (((state wp) (extract-process state pid))) (if (not wp) state - (unwrap-process State vm (p wp) + (let ((p wp)) (match (assoc spawn-k-id (process-spawn-ks p)) [#f - (inject-process state (mkProcess p))] + (inject-process state p)] [(and entry (cons _ k)) (define interruptk (send-to-user p (e) (quit-interruptk e) (k new-pid))) (define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))])) - (inject-process state (mkProcess (run-ready p1 interruptk)))])))))) + (inject-process state (run-ready p1 interruptk))])))))) -(: transform-meta-action : (All (State) (PreAction State) (process State) vm -> - (Values (Option (process State)) vm (QuasiQueue (Action vm))))) +;; transform-meta-action : (All (State) (PreAction State) (process State) vm -> +;; (Values (Option (process State)) vm (QuasiQueue (Action vm)))) (define (transform-meta-action pa p state) (match pa [(add-endpoint pre-eid role unwrapped-handler) @@ -180,13 +179,12 @@ (values (struct-copy process p [meta-endpoints (hash-set (process-meta-endpoints p) pre-eid - ((inst endpoint State) - new-eid - role - unwrapped-handler))]) + (endpoint new-eid + role + unwrapped-handler))]) state (quasiqueue - (add-endpoint (cast new-eid PreEID) + (add-endpoint new-eid role (wrap-trapk new-eid))))] [(delete-endpoint pre-eid reason) @@ -194,7 +192,7 @@ (values (struct-copy process p [meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)]) state - (quasiqueue (delete-endpoint (cast old-eid PreEID) reason)))] + (quasiqueue (delete-endpoint old-eid reason)))] [(send-message body orientation) (values p state @@ -202,15 +200,14 @@ [(spawn spec k debug-name) (define pid (process-pid p)) (if k - (let ((spawn-k-id (+ 1 (list-max (map (inst car Integer (TrapK PID State)) - (process-spawn-ks p)))))) + (let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p)))))) (values (struct-copy process p [spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))]) state (quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name)))) (values p state - (quasiqueue ((inst spawn vm) spec #f debug-name))))] + (quasiqueue (spawn spec #f debug-name))))] [(quit maybe-pid reason) (values p state diff --git a/drivers/event-relay.rkt b/drivers/event-relay.rkt index 758195a..9464fe8 100644 --- a/drivers/event-relay.rkt +++ b/drivers/event-relay.rkt @@ -1,30 +1,27 @@ -#lang typed/racket/base +#lang racket/base ;; Ground-event relay. (provide event-relay) -(require "../sugar-typed.rkt") -(require "../support/event.rkt") +(require "../sugar.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: #:parent : ParentState - #:child : Void - (transition/no-state - (observe-subscribers: Void (cons ? ?) - (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) + (spawn (transition/no-state + (observe-subscribers (cons ? ?) + (match-conversation (cons (? evt? e) _) + (on-presence (begin + (printf "SUBSCRIBED ~v~n" e) (flush-output) - (at-meta-level: Void - (delete-endpoint `(event-relay ,self-id ,e))))))))))) + (at-meta-level + (name-endpoint `(event-relay ,self-id ,e) + (subscriber (cons e ?) + (on-message + [msg (begin (printf "FIRED ~v -> ~v~n" e msg) + (flush-output) + (send-message msg))])))))) + (on-absence (begin + (printf "UNSUBSCRIBED ~v~n" e) + (flush-output) + (at-meta-level + (delete-endpoint `(event-relay ,self-id ,e))))))))))) diff --git a/drivers/tcp-bare-with-ground.rkt b/drivers/tcp-bare-with-ground.rkt index bfb9598..4b78f72 100644 --- a/drivers/tcp-bare-with-ground.rkt +++ b/drivers/tcp-bare-with-ground.rkt @@ -5,8 +5,9 @@ (require racket/match) (require (prefix-in tcp: racket/tcp)) (require racket/port) -(require "../sugar-untyped.rkt") +(require "../sugar.rkt") (require "../support/dump-bytes.rkt") +(require "../unify.rkt") (provide (struct-out tcp-address) (struct-out tcp-handle) diff --git a/drivers/tcp-bare.rkt b/drivers/tcp-bare.rkt index 656ba27..1c6527b 100644 --- a/drivers/tcp-bare.rkt +++ b/drivers/tcp-bare.rkt @@ -5,7 +5,7 @@ (require racket/match) (require (prefix-in tcp: racket/tcp)) (require racket/port) -(require "../sugar-untyped.rkt") +(require "../sugar.rkt") (require "../support/dump-bytes.rkt") (provide (struct-out tcp-address) diff --git a/drivers/tcp.rkt b/drivers/tcp.rkt index e046a32..0e0387c 100644 --- a/drivers/tcp.rkt +++ b/drivers/tcp.rkt @@ -5,8 +5,9 @@ (require racket/match) (require (prefix-in tcp: racket/tcp)) (require racket/port) -(require "../sugar-untyped.rkt") +(require "../sugar.rkt") (require "../support/dump-bytes.rkt") +(require "../unify.rkt") (provide (struct-out tcp-address) (struct-out tcp-handle) diff --git a/drivers/timer-untyped.rkt b/drivers/timer-untyped.rkt deleted file mode 100644 index 7babb85..0000000 --- a/drivers/timer-untyped.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket/base -;; Untyped-Racket support for Timer driver. - -(require "timer.rkt") -(provide (except-out (all-from-out "timer.rkt") - set-timer - set-timer-pattern - timer-expired - timer-expired-pattern) - (rename-out [set-timer-repr set-timer] - [set-timer-repr set-timer-pattern] - [timer-expired-repr timer-expired] - [timer-expired-repr timer-expired-pattern])) diff --git a/drivers/timer.rkt b/drivers/timer.rkt index daf2222..6d92bc8 100644 --- a/drivers/timer.rkt +++ b/drivers/timer.rkt @@ -1,4 +1,4 @@ -#lang typed/racket/base +#lang racket/base ;; Timer driver. ;; Uses mutable state internally, but because the scope of the @@ -7,103 +7,48 @@ (require racket/set) (require racket/match) -(require "../sugar-typed.rkt") -(require "../support/event.rkt") -(require "../support/pseudo-substruct.rkt") - -(require/typed typed/racket/base - [wrap-evt (Evt (Any -> Real) -> Evt)]) +(require data/heap) +(require "../sugar.rkt") ;; (pending-timer AbsoluteSeconds Any Boolean) ;; An outstanding timer being managed by the timer-driver. -(struct: pending-timer ([deadline : Real] - [label : TimerLabel]) - #:transparent) - -(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? +(struct pending-timer (deadline ;; Real + label ;; TimerLabel + ) + #:transparent) +(provide (struct-out set-timer) + (struct-out timer-expired) timer-driver timer-relay) -(define-type TimerLabel Any) - -(define-type TimerKind (U 'relative 'absolute)) +;; (define-type TimerKind (U 'relative 'absolute)) ;; The timer driver and timer relays listen for messages of this type, ;; and when they hear one, they set an alarm that will later send a ;; corresponding timer-expired message. -(struct: (TLabel TMsecs TKind) - set-timer-repr ([label : TLabel] - [msecs : TMsecs] - [kind : TKind]) - #:transparent) - -(pseudo-substruct: (set-timer-repr TimerLabel Real TimerKind) - SetTimer set-timer set-timer?) -(pseudo-substruct: (set-timer-repr (U Wild TimerLabel) - (U Wild Real) - (U Wild TimerKind)) - SetTimerPattern set-timer-pattern set-timer-pattern?) +(struct set-timer (label msecs kind) #:transparent) ;; Message sent by the timer driver or a timer relay upon expiry of a ;; timer. Contains the label specified in the corresponding set-timer ;; message, and also the current absolute time from the outside world. -(struct: (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?) +(struct timer-expired (label msecs) #:transparent) ;; State of a timer-driver, including the identifier of the driver, ;; the currently-active subscription to ground time events (if any), ;; and the heap of all remaining timers. -(struct: driver-state ([heap : Heap]) #:transparent) +(struct driver-state (heap) #:transparent) -(define-type DriverState driver-state) - -(define-type RelayKey Exact-Nonnegative-Integer) +;; (define-type RelayKey Exact-Nonnegative-Integer) ;; State of a timer-relay, including the next timer number and a ;; mapping from timer number to timer label. -(struct: relay-state ([next-counter : RelayKey] - [active-timers : (HashTable RelayKey TimerLabel)]) - #:transparent) +(struct relay-state (next-counter ;; RelayKey + active-timers ;; (HashTable RelayKey TimerLabel) + ) + #: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)), @@ -114,18 +59,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 @@ -133,7 +78,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)) '() @@ -146,70 +91,64 @@ ;; 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: #:parent : ParentState - #:child : DriverState - (transition: (driver-state (make-timer-heap)) : DriverState - (subscriber: DriverState (set-timer-pattern (wild) (wild) (wild)) - (match-state state - (on-message - [(set-timer label msecs 'relative) - (install-timer! state label (+ (current-inexact-milliseconds) msecs))] - [(set-timer label msecs 'absolute) - (install-timer! state label msecs)]))) - (publisher: DriverState (timer-expired-pattern (wild) (wild))))))) + (spawn (transition (driver-state (make-timer-heap)) + (subscriber (set-timer (wild) (wild) (wild)) + (match-state state + (on-message + [(set-timer label msecs 'relative) + (install-timer! state label (+ (current-inexact-milliseconds) msecs))] + [(set-timer label msecs 'absolute) + (install-timer! state label msecs)]))) + (publisher (timer-expired (wild) (wild))))))) -(: install-timer! : DriverState TimerLabel Real -> (Transition DriverState)) +;; 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 : DriverState + (transition state (delete-endpoint 'time-listener) (and next (name-endpoint 'time-listener - (subscriber: DriverState (cons (timer-evt (pending-timer-deadline next)) (wild)) + (subscriber (cons (timer-evt (pending-timer-deadline next)) (wild)) (match-state state (on-message [(cons (? evt?) (? real? now)) (let ((to-send (fire-timers! (driver-state-heap state) now))) ;; Note: compute to-send before recursing, because of side-effects on heap - (sequence-actions (transition: state : DriverState) - update-time-listener! - to-send))]))))))) + (sequence-actions (transition state) + update-time-listener! + to-send))]))))))) ;; Process for mapping this-level timer requests to meta-level timer ;; requests. Useful when running nested VMs: essentially extends timer ;; support up the branches of the VM tree toward the leaves. -(: timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))) +;; timer-relay : (All (ParentState) Symbol -> (Spawn ParentState)) (define (timer-relay self-id) (name-process `(timer-relay ,self-id) - (spawn: #:parent : ParentState - #:child : RelayState - (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)) + (spawn (transition (relay-state 0 (make-immutable-hash '())) + (at-meta-level + (subscriber (timer-expired (wild) (wild)) (match-state (relay-state next-counter active-timers) (on-message - [(set-timer label msecs kind) - (transition: (relay-state (+ next-counter 1) - (hash-set active-timers next-counter label)) - : RelayState - (at-meta-level: RelayState - (send-message (set-timer (list self-id next-counter) msecs kind))))]))) - (publisher: RelayState (timer-expired-pattern (wild) (wild))))))) + [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter)) + now) + (transition (relay-state next-counter (hash-remove active-timers counter)) + (and (hash-has-key? active-timers counter) + (send-message (timer-expired (hash-ref active-timers counter) + now))))])))) + (subscriber (set-timer (wild) (wild) (wild)) + (match-state (relay-state next-counter active-timers) + (on-message + [(set-timer label msecs kind) + (transition (relay-state (+ next-counter 1) + (hash-set active-timers next-counter label)) + (at-meta-level + (send-message (set-timer (list self-id next-counter) msecs kind))))]))) + (publisher (timer-expired (wild) (wild))))))) diff --git a/drivers/udp-untyped.rkt b/drivers/udp-untyped.rkt deleted file mode 100644 index 1239ab5..0000000 --- a/drivers/udp-untyped.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket/base -;; UDP driver. Untyped macro wrappers - -(require "udp.rkt") -(provide (except-out (all-from-out "udp.rkt") - udp-remote-address - udp-remote-address-pattern - udp-handle - udp-handle-pattern - udp-listener - udp-listener-pattern - udp-packet - udp-packet-pattern) - (rename-out [udp-remote-address-repr udp-remote-address] - [udp-remote-address-repr udp-remote-address-pattern] - [udp-handle-repr udp-handle] - [udp-handle-repr udp-handle-pattern] - [udp-listener-repr udp-listener] - [udp-listener-repr udp-listener-pattern] - [udp-packet-repr udp-packet] - [udp-packet-repr udp-packet-pattern])) diff --git a/drivers/udp.rkt b/drivers/udp.rkt index e98e54f..26ad406 100644 --- a/drivers/udp.rkt +++ b/drivers/udp.rkt @@ -1,43 +1,20 @@ -#lang typed/racket/base +#lang racket/base ;; UDP driver. (require racket/set) (require racket/match) +(require racket/udp) -(require "../support/event.rkt") -(require (except-in racket/udp udp-receive!-evt)) -(require/typed racket/udp - [udp-receive!-evt (UDP-Socket Bytes -> Evt)]) +(require "../sugar.rkt") -(require "../sugar-typed.rkt") -(require "../support/event.rkt") -(require "../support/pseudo-substruct.rkt") - -(provide (struct-out udp-remote-address-repr) - UdpRemoteAddress udp-remote-address udp-remote-address? - UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern? - - (struct-out udp-handle-repr) - UdpHandle udp-handle udp-handle? - UdpHandlePattern udp-handle-pattern udp-handle-pattern? - - (struct-out udp-listener-repr) - UdpListener udp-listener udp-listener? - UdpListenerPattern udp-listener-pattern udp-listener-pattern? - - UdpAddress - UdpAddressPattern - - UdpLocalAddress +(provide (struct-out udp-remote-address) + (struct-out udp-handle) + (struct-out udp-listener) udp-address? - udp-address-pattern? udp-local-address? - (struct-out udp-packet-repr) - UdpPacket udp-packet udp-packet? - UdpPacketPattern udp-packet-pattern udp-packet-pattern? - + (struct-out udp-packet) udp-driver) ;; A UdpAddress is one of @@ -48,171 +25,122 @@ ;; to the local VM, i.e. shared between processes in that VM, so ;; processes must make sure not to accidentally clash in handle ID ;; selection. -(struct: (THost TPort) - udp-remote-address-repr ([host : THost] - [port : TPort]) - #:transparent) -(pseudo-substruct: (udp-remote-address-repr String Natural) - UdpRemoteAddress udp-remote-address udp-remote-address?) -(pseudo-substruct: (udp-remote-address-repr (U Wild String) (U Wild Natural)) - UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?) +(struct udp-remote-address (host port) #:transparent) +(struct udp-handle (id) #:transparent) +(struct udp-listener (port) #:transparent) -(struct: (TId) - udp-handle-repr ([id : TId]) - #:transparent) -(pseudo-substruct: (udp-handle-repr Any) - UdpHandle udp-handle udp-handle?) -(pseudo-substruct: (udp-handle-repr (U Wild Any)) - UdpHandlePattern udp-handle-pattern udp-handle-pattern?) +(define (udp-address? x) + (or (udp-remote-address? x) + (udp-handle? x) + (udp-listener? x))) -(struct: (TPort) - udp-listener-repr ([port : TPort]) - #:transparent) -(pseudo-substruct: (udp-listener-repr Natural) - UdpListener udp-listener udp-listener?) -(pseudo-substruct: (udp-listener-repr (U Wild Natural)) - UdpListenerPattern udp-listener-pattern udp-listener-pattern?) - -(define-type UdpAddress (U UdpRemoteAddress UdpHandle UdpListener)) -(define-type UdpAddressPattern (U Wild UdpRemoteAddressPattern UdpHandlePattern UdpListenerPattern)) - -(define-type UdpLocalAddress (U UdpHandle UdpListener)) - -(define-predicate udp-address? UdpAddress) -(define-predicate udp-address-pattern? UdpAddressPattern) -(define-predicate udp-local-address? UdpLocalAddress) +(define (udp-local-address? x) + (or (udp-handle? x) + (udp-listener? x))) ;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and ;; represents a packet appearing on our local "subnet" of the full UDP ;; network, complete with source, destination and contents. -(struct: (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?) +(struct udp-packet (source destination body) #:transparent) ;; A HandleMapping is a record describing a mapping between a local ;; UdpAddress and its underlying UDP socket. It's private to the ;; implementation of the driver. -(struct: (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?) +(struct handle-mapping (address socket) #:transparent) ;; TODO: BUG?: Routing packets between two local sockets won't work ;; because the patterns aren't set up to recognise that situation. ;; represents any remote address -(: any-remote : UdpAddressPattern) -(define any-remote (udp-remote-address-pattern (wild) (wild))) +;; any-remote : UdpAddressPattern +(define any-remote (udp-remote-address (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-pattern _ (? udp-local-address? local-addr) _) topic) + (match-define (udp-packet _ (? udp-local-address? local-addr) _) topic) (cond [(set-member? active-handles local-addr) - (transition: active-handles : DriverState)] + (transition active-handles)] [else - (transition: (set-add active-handles local-addr) : DriverState + (transition (set-add active-handles local-addr) (udp-socket-manager local-addr))])) (name-process 'udp-driver - (spawn: #:parent : ParentState - #:child : DriverState - (transition: ((inst set UdpLocalAddress)) : DriverState + (spawn (transition (set) - (observe-subscribers: DriverState - (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) - (match-state active-handles - (match-conversation topic - (on-presence (handle-presence topic active-handles))))) - (observe-subscribers: 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: DriverState - (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) - (match-state active-handles - (match-conversation topic - (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-subscribers (udp-packet any-remote (udp-handle (wild)) (wild)) + (match-state active-handles + (match-conversation topic + (on-presence (handle-presence topic active-handles))))) + (observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild)) + (match-state active-handles + (match-conversation topic + (on-presence (handle-presence topic active-handles))))) + (observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild)) + (match-state active-handles + (match-conversation topic + (on-presence (handle-presence topic active-handles))))) + (observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild)) + (match-state active-handles + (match-conversation topic + (on-presence (handle-presence topic active-handles))))) - (observe-publishers: DriverState (handle-mapping-pattern (wild) (wild)) - (match-state active-handles - (match-conversation (handle-mapping local-addr socket) - (on-absence - (transition: (set-remove active-handles local-addr) : DriverState))))) - )))) + (observe-publishers (handle-mapping (wild) (wild)) + (match-state active-handles + (match-conversation (handle-mapping local-addr socket) + (on-absence + (transition (set-remove active-handles local-addr)))))) + )))) -(: bind-socket! : UDP-Socket UdpLocalAddress -> Void) +;; 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 : SocketManagerState + (transition #f (quit) (when socket-is-open? (name-process `(udp-socket-closer ,local-addr) - (spawn: #:parent : SocketManagerState - #:child : Void - (begin (udp-close s) - (transition: (void) : Void (quit)))))))) + (spawn (begin (udp-close s) + (transition (void) (quit)))))))) (name-process `(udp-socket-manager ,local-addr) - (spawn: #:parent : DriverState - #:child : SocketManagerState - (transition: #t : SocketManagerState + (spawn (transition #t ;; Offers a handle-mapping on the local network so that ;; the driver/factory can clean up when this process dies. - (publisher: SocketManagerState (handle-mapping local-addr s)) + (publisher (handle-mapping local-addr s)) ;; If our counterparty removes either of their endpoints ;; as the subscriber end of the remote-to-local stream or ;; the publisher end of the local-to-remote stream, shut ;; ourselves down. Also, relay messages published on the ;; local-to-remote stream out on the actual socket. - (publisher: SocketManagerState - (udp-packet-pattern any-remote local-addr (wild)) + (publisher (udp-packet any-remote local-addr (wild)) (match-state socket-is-open? (on-absence (handle-absence socket-is-open?)))) - (subscriber: SocketManagerState - (udp-packet-pattern local-addr any-remote (wild)) + (subscriber (udp-packet local-addr any-remote (wild)) (match-state socket-is-open? (on-absence (handle-absence socket-is-open?)) (on-message @@ -220,10 +148,10 @@ (udp-remote-address remote-host remote-port) body) (begin (udp-send-to s remote-host remote-port body) - (transition: socket-is-open? : SocketManagerState))]))) + (transition socket-is-open?))]))) ;; Listen for messages arriving on the actual socket using ;; a ground event, and relay them at this level. - (subscriber: SocketManagerState (cons (udp-receive!-evt s buffer) (wild)) + (subscriber (cons (udp-receive!-evt s buffer) (wild)) (on-message [(cons (? evt?) (list (? exact-integer? packet-length) (? string? remote-host) diff --git a/examples/echo-plain.rkt b/examples/echo-plain.rkt index 9625f78..80a8568 100644 --- a/examples/echo-plain.rkt +++ b/examples/echo-plain.rkt @@ -1,7 +1,7 @@ #lang racket/base ;; Plain Racket version, using (require) instead of #lang marketplace. -(require marketplace/sugar-untyped) +(require marketplace/sugar) (require marketplace/drivers/tcp-bare) (define (echoer from to) diff --git a/ground.rkt b/ground.rkt index 5a67aba..ff0663f 100644 --- a/ground.rkt +++ b/ground.rkt @@ -1,25 +1,18 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") -(require "log-typed.rkt") +(require "log.rkt") (require "process.rkt") (require "actions.rkt") (require "action-send-message.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround -(require "support/event.rkt") - -(require/typed typed/racket/base - [sync (Evt Evt * -> (vm -> vm))] - [never-evt Evt] - [always-evt Evt] - [wrap-evt (Evt (Any -> (vm -> vm)) -> Evt)]) +(require "quasiqueue.rkt") (provide run-ground-vm) -(: run-ground-vm : process-spec -> Void) +;; run-ground-vm : process-spec -> Void (define (run-ground-vm boot) (let loop ((state (make-vm boot))) (match (run-vm state) @@ -38,7 +31,7 @@ "Cannot process meta-actions ~v because no further metalevel exists" actions)])) (define active-events - ((inst endpoint-fold (Listof Evt)) extract-ground-event-subscriptions '() state)) + (endpoint-fold extract-ground-event-subscriptions '() state)) (if (and is-blocking? (null? active-events)) (begin @@ -49,27 +42,27 @@ (let ((interruptk (apply sync (if is-blocking? never-evt - (wrap-evt always-evt (lambda (dummy) (inst values vm)))) + (wrap-evt always-evt (lambda (dummy) values))) active-events))) (loop (interruptk state))))]))) -(: extract-ground-event-subscriptions : - (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))) +;; extract-ground-event-subscriptions : +;; (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt)) (define (extract-ground-event-subscriptions old-p ep acc) (define pid (process-pid old-p)) (match (endpoint-role ep) [(role 'subscriber (cons (? evt? evt) _) 'participant) - (: evt-handler : Any -> (vm -> vm)) + ;; evt-handler : Any -> (vm -> vm) (define ((evt-handler message) state) (let-values (((state wp) (extract-process state pid))) (if (not wp) state - (unwrap-process State vm (p wp) + (let ((p wp)) (let-values (((p state) - (do-send-message 'publisher (cast (cons evt message) Message) p state))) + (do-send-message 'publisher (cons evt message) p state))) (if p - (inject-process state (mkProcess p)) + (inject-process state p) state)))))) (cons (wrap-evt evt evt-handler) acc)] [_ acc])) diff --git a/lang/base.rkt b/lang/base.rkt index 0f5625a..220531f 100644 --- a/lang/base.rkt +++ b/lang/base.rkt @@ -3,13 +3,13 @@ (require (for-syntax racket/base)) (require (for-syntax racket/pretty)) -(require "../sugar-untyped.rkt") +(require "../sugar.rkt") (require "../drivers/tcp-bare.rkt") (require "../support/spy.rkt") (provide (rename-out [module-begin #%module-begin]) (except-out (all-from-out racket/base) #%module-begin) - (all-from-out "../sugar-untyped.rkt") + (all-from-out "../sugar.rkt") (all-from-out "../drivers/tcp-bare.rkt") (all-from-out "../support/spy.rkt") stateless) diff --git a/list-utils.rkt b/list-utils.rkt index 21cb257..82c9143 100644 --- a/list-utils.rkt +++ b/list-utils.rkt @@ -1,7 +1,7 @@ -#lang typed/racket/base +#lang racket/base (provide list-max) -(: list-max : (Listof Integer) -> Integer) +;; list-max : (Listof Integer) -> Integer (define (list-max xs) (foldr max 0 xs)) diff --git a/log-typed.rkt b/log-typed.rkt deleted file mode 100644 index c0af828..0000000 --- a/log-typed.rkt +++ /dev/null @@ -1,17 +0,0 @@ -#lang typed/racket/base - -(require/typed "log-untyped.rkt" - [marketplace-root-logger Logger]) - -;; WARNING: duplicated in log-untyped.rkt -(define-syntax marketplace-log - (syntax-rules () - [(_ level-exp message) - (let ((level level-exp)) - (when (log-level? marketplace-root-logger level) - (log-message marketplace-root-logger level message #f)))] - [(_ level format-string exp ...) - (marketplace-log level (format format-string exp ...))])) - -(provide marketplace-root-logger - marketplace-log) diff --git a/log-untyped.rkt b/log.rkt similarity index 96% rename from log-untyped.rkt rename to log.rkt index 9b3a128..1582a3e 100644 --- a/log-untyped.rkt +++ b/log.rkt @@ -7,7 +7,6 @@ (define marketplace-root-logger (make-logger 'marketplace #f)) -;; WARNING: duplicated in log-typed.rkt (define-syntax marketplace-log (syntax-rules () [(_ level-exp message) diff --git a/main.rkt b/main.rkt index de5706d..7e0ce1d 100644 --- a/main.rkt +++ b/main.rkt @@ -1,34 +1,26 @@ -#lang typed/racket/base -;; Virtualized operating system, this time with presence and types. +#lang racket/base +;; Virtualized operating system, this time with presence. ;; TODO: contracts for State checking -;; TODO: types for Message and MetaMessage (will require rethinking at-meta-level spawn) ;; TODO: revisit exposure of PIDs to processes. ;; - make processes parametric in the PID type? ;; - simply make PIDs unavailable to processes? ;; - revisit points-of-attachment idea, and expose presence on PIDs properly? (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") (require "actions.rkt") (require "nested.rkt") (require "ground.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "unify.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") +(provide (all-from-out "structs.rkt") (all-from-out "roles.rkt") make-nested-vm run-ground-vm - Wild wild wild? non-wild? diff --git a/nested.rkt b/nested.rkt index 18cfc1c..e8a461a 100644 --- a/nested.rkt +++ b/nested.rkt @@ -1,18 +1,17 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") (require "actions.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (provide make-nested-vm) -(: make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))) +;; make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State)) (define (make-nested-vm make-boot debug-name) (spawn (process-spec (lambda (nested-vm-pid) - (lambda (k) ((inst k vm) (run-vm (make-vm (make-boot nested-vm-pid))))))) + (lambda (k) (k (run-vm (make-vm (make-boot nested-vm-pid))))))) #f debug-name)) diff --git a/opaque-any.rkt b/opaque-any.rkt deleted file mode 100644 index f93e02b..0000000 --- a/opaque-any.rkt +++ /dev/null @@ -1,9 +0,0 @@ -#lang racket/base - -(provide topic? - pre-eid? - reason?) - -(define (topic? x) #t) -(define (pre-eid? x) #t) -(define (reason? x) #t) diff --git a/process.rkt b/process.rkt index 518eb93..036eb02 100644 --- a/process.rkt +++ b/process.rkt @@ -1,11 +1,11 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") (require "vm.rkt") -(require "log-typed.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "log.rkt") +(require "quasiqueue.rkt") (provide send-to-user send-to-user* @@ -18,7 +18,7 @@ (send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr)) (define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr) - (with-handlers ([exn:fail? (lambda: ([e : Reason]) + (with-handlers ([exn:fail? (lambda (e) (if (exn? e) (marketplace-log 'error "Process ~v(~v):~n~a~n" debug-name pid (exn-message e)) @@ -30,44 +30,37 @@ (marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid) result)) -(: action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))) +;; action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State))) +;; TODO: simplify (define (action-tree->quasiqueue t) - (let loop ((#{revacc : (QuasiQueue (Action State))} '()) (t t)) - ;; 1. Tried match with (define-predicate action? Action). - ;; Failed because of parametric function contracts. - ;; 2. Tried flipping the order or clauses in the match to - ;; avoid the use of (action?), trying to pull out the - ;; false/nil/void leaving only, by exclusion, the - ;; Action. Failed, complaining that it didn't know the - ;; type in the third, default, branch. - ;; 3. Just like 2, but with cond. This worked! + (let loop ((revacc '()) (t t)) (cond [(pair? t) (loop (loop revacc (car t)) (cdr t))] [(or (null? t) (eq? t #f) (void? t)) revacc] [else (cons t revacc)]))) ;; Split out to provide a syntactic location to define State in -(: quit-interruptk : Reason -> (All (State) State -> (Transition State))) +;; quit-interruptk : Reason -> (All (State) State -> (Transition State)) (define ((quit-interruptk e) old-process-state) (transition old-process-state (quit #f e))) -(: run-ready : (All (State) (process State) (InterruptK State) -> (process State))) +;; run-ready : (All (State) (process State) (InterruptK State) -> (process State)) (define (run-ready p interruptk) (define old-state (process-state p)) (match-define (transition new-state actions) - (send-to-user p (e) (transition old-state (ann (quit #f e) (Action State))) + (send-to-user p (e) (transition old-state (quit #f e)) (interruptk old-state))) (struct-copy process p [state new-state] [pending-actions (quasiqueue-append (process-pending-actions p) (action-tree->quasiqueue actions))])) -(: notify-route-change-self : (All (SNew) - (process SNew) - (endpoint SNew) - (Role -> EndpointEvent) - -> - (process SNew))) +;; notify-route-change-self : (All (SNew) +;; (process SNew) +;; (endpoint SNew) +;; (Role -> EndpointEvent) +;; -> +;; (process SNew)) (define (notify-route-change-self pn en flow->notification) (define endpointso (process-endpoints pn)) (for/fold ([pn pn]) ([eido (in-hash-keys endpointso)]) @@ -86,13 +79,13 @@ flow->notification))] [else pn]))) -(: notify-route-change-process : (All (SOld SNew) - (process SOld) - (process SNew) - (endpoint SNew) - (Role -> EndpointEvent) - -> (values (process SOld) - (process SNew)))) +;; notify-route-change-process : (All (SOld SNew) +;; (process SOld) +;; (process SNew) +;; (endpoint SNew) +;; (Role -> EndpointEvent) +;; -> (values (process SOld) +;; (process SNew))) (define (notify-route-change-process po pn en flow->notification) (define endpointso (process-endpoints po)) (for/fold ([po po] @@ -109,39 +102,37 @@ [else (values po pn)]))) -(: invoke-handler-if-visible : (All (State) - (process State) - (endpoint State) - Role - (Role -> EndpointEvent) - -> - (process State))) +;; invoke-handler-if-visible : (All (State) +;; (process State) +;; (endpoint State) +;; Role +;; (Role -> EndpointEvent) +;; -> +;; (process State)) (define (invoke-handler-if-visible p ep flow flow->notification) (if (flow-visible? (endpoint-role ep) flow) (run-ready p (send-to-user p (e) (quit-interruptk e) ((endpoint-handler ep) (flow->notification flow)))) p)) -(: notify-route-change-vm : (All (SNew) - (process SNew) - (endpoint SNew) - (Role -> EndpointEvent) - vm - -> (values (process SNew) - vm))) +;; notify-route-change-vm : (All (SNew) +;; (process SNew) +;; (endpoint SNew) +;; (Role -> EndpointEvent) +;; vm +;; -> (values (process SNew) +;; vm)) (define (notify-route-change-vm pn en flow->notification state) (define old-processes (vm-processes state)) (define-values (final-pn new-processes) - (for/fold: : (values (process SNew) - (HashTable PID Process)) - ([pn (notify-route-change-self pn en flow->notification)] - [new-processes (ann #hash() (HashTable PID Process))]) + (for/fold ([pn (notify-route-change-self pn en flow->notification)] + [new-processes #hash()]) ([pid (in-hash-keys old-processes)]) (define wp (hash-ref old-processes pid)) (apply values - (unwrap-process SOld (List (process SNew) (HashTable PID Process)) (po wp) + (let ((po wp)) (let-values (((po pn) (notify-route-change-process po pn en flow->notification))) - (list pn (hash-set new-processes pid (mkProcess po)))))))) + (list pn (hash-set new-processes pid po))))))) (values final-pn (struct-copy vm state [processes new-processes]))) diff --git a/quasiqueue.rkt b/quasiqueue.rkt index 6b902d7..b743a39 100644 --- a/quasiqueue.rkt +++ b/quasiqueue.rkt @@ -1,8 +1,6 @@ -#lang typed/racket/base +#lang racket/base -(provide QuasiQueue - Constreeof - empty-quasiqueue +(provide empty-quasiqueue quasiqueue-empty? quasiqueue-append-list quasiqueue-append @@ -12,40 +10,36 @@ quasiqueue->cons-tree) ;; A QuasiQueue 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) -- 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))))) + (reverse q)) diff --git a/roles.rkt b/roles.rkt index 76f685e..fb5ca52 100644 --- a/roles.rkt +++ b/roles.rkt @@ -1,14 +1,9 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") -(require "log-typed.rkt") -(require/typed "unify.rkt" - [wild (case-> (-> Topic) (Symbol -> Topic))] - [mgu-canonical (Topic Topic -> Topic)] - [freshen (Topic -> Topic)] - [specialization? (Topic Topic -> Boolean)]) -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "structs.rkt") +(require "log.rkt") +(require "unify.rkt") (provide co-orientations co-roles @@ -18,34 +13,34 @@ role-intersection flow-visible?) -(: co-orientations : Orientation -> (Listof Orientation)) +;; co-orientations : Orientation -> (Listof Orientation) (define (co-orientations o) (match o ['publisher '(subscriber)] ['subscriber '(publisher)])) -(: co-roles : Role -> (Listof Role)) +;; co-roles : Role -> (Listof Role) (define (co-roles r) - (for/list: ([co-orientation : Orientation (co-orientations (role-orientation r))]) + (for/list ([co-orientation (co-orientations (role-orientation r))]) (struct-copy role r [orientation co-orientation]))) -(: refine-role : Role Topic -> Role) +;; refine-role : Role Topic -> Role (define (refine-role remote-role new-topic) (struct-copy role remote-role [topic new-topic])) -(: roles-equal? : Role Role -> Boolean) +;; roles-equal? : Role Role -> Boolean (define (roles-equal? ta tb) (and (equal? (role-orientation ta) (role-orientation tb)) (equal? (role-interest-type ta) (role-interest-type tb)) (specialization? (role-topic ta) (role-topic tb)) (specialization? (role-topic tb) (role-topic ta)))) -(: orientations-intersect? : Orientation Orientation -> Boolean) +;; orientations-intersect? : Orientation Orientation -> Boolean (define (orientations-intersect? l r) (and (memq l (co-orientations r)) #t)) ;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean? -(: role-intersection : Role Role -> (Option Topic)) +;; role-intersection : Role Role -> (Option Topic) (define (role-intersection left right) (define result (and (orientations-intersect? (role-orientation left) (role-orientation right)) @@ -72,7 +67,7 @@ ;; | 'everything | 'everything | yes | ;; |--------------+--------------+------------------------| ;; -(: flow-visible? : Role Role -> Boolean) +;; flow-visible? : Role Role -> Boolean (define (flow-visible? local-role remote-role) (or (eq? (role-interest-type remote-role) 'participant) (eq? (role-interest-type local-role) 'everything))) diff --git a/scribblings/highlevel.scrbl b/scribblings/highlevel.scrbl index 12e63aa..abc6a82 100644 --- a/scribblings/highlevel.scrbl +++ b/scribblings/highlevel.scrbl @@ -4,9 +4,7 @@ @title[#:tag "high-level-interface"]{High-level interface} -@declare-exporting[#:use-sources (marketplace/sugar-values - marketplace/sugar-untyped - marketplace/sugar-typed)] +@declare-exporting[#:use-sources (marketplace/sugar)] This high-level interface between a VM and a process is analogous to the @emph{C library interface} of a Unix-like operating system. The @@ -60,11 +58,8 @@ and @racket[ground-vm:] explicitly. @section{Using Marketplace as a library} -@defmodule*[(marketplace/sugar-untyped - marketplace/sugar-typed) - #:use-sources (marketplace/sugar-values - marketplace/sugar-untyped - marketplace/sugar-typed)] +@defmodule*[(marketplace/sugar) + #:use-sources (marketplace/sugar)] Instead of using Racket's @tt{#lang} feature, ordinary Racket programs can use Marketplace features by requiring Marketplace modules @@ -110,9 +105,7 @@ its state type). @section[#:tag "constructing-transitions"]{Constructing transitions} @declare-exporting[#:use-sources (marketplace - marketplace/sugar-values - marketplace/sugar-untyped - marketplace/sugar-typed)] + marketplace/sugar)] @deftogether[( @defform[(transition new-state action-tree ...)] diff --git a/scribblings/lowlevel.scrbl b/scribblings/lowlevel.scrbl index 4d575f0..ea6f041 100644 --- a/scribblings/lowlevel.scrbl +++ b/scribblings/lowlevel.scrbl @@ -41,8 +41,8 @@ Typed Racket types capturing various notions of handler function. @section{Messages, Topics and Roles} -@declare-exporting[marketplace marketplace/sugar-untyped marketplace/sugar-typed - #:use-sources (marketplace marketplace/sugar-untyped marketplace/sugar-typed)] +@declare-exporting[marketplace marketplace/sugar + #:use-sources (marketplace marketplace/sugar)] @deftogether[( @deftype[Message Any] @@ -255,8 +255,8 @@ Deletes an existing endpoint named @racket[pre-eid]. The given If no specific reason is needed, it is conventional to supply @racket[#f] as the @racket[delete-endpoint-reason]. See also the -convenience @from[marketplace/sugar-values]{@racket[delete-endpoint]} -function from @racket[marketplace/sugar-values]. +convenience @from[marketplace/sugar]{@racket[delete-endpoint]} +function from @racket[marketplace/sugar]. } @@ -270,9 +270,9 @@ the containing VM.} The given @racket[Orientation] should describe the role the sender is playing when sending this message: usually, it will be @racket['publisher], but when the message is @emph{feedback} for some publisher, it will be @racket['subscriber]. -@from[marketplace/sugar-values]{See also the @racket[send-message] and +@from[marketplace/sugar]{See also the @racket[send-message] and @racket[send-feedback] convenience functions from -@racket[marketplace/sugar-values].} +@racket[marketplace/sugar].} } diff --git a/scribblings/management-and-monitoring.scrbl b/scribblings/management-and-monitoring.scrbl index ece5622..5911717 100644 --- a/scribblings/management-and-monitoring.scrbl +++ b/scribblings/management-and-monitoring.scrbl @@ -4,10 +4,7 @@ @require[(for-label marketplace/support/spy marketplace/support/debug - marketplace/log-untyped - (except-in marketplace/log-typed - marketplace-log - marketplace-root-logger))] + marketplace/log)] @title{Management and Monitoring} diff --git a/scribblings/prelude.inc b/scribblings/prelude.inc index 04e3108..d1e3dfd 100644 --- a/scribblings/prelude.inc +++ b/scribblings/prelude.inc @@ -12,21 +12,7 @@ (for-label typed/racket/base)) (require (for-label (only-in marketplace/drivers/tcp-bare tcp) - (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))) + marketplace/sugar)) ;; TODO: make it display "=" instead of ":" connecting the defined ;; type to the definition. diff --git a/structs.rkt b/structs.rkt new file mode 100644 index 0000000..76305dd --- /dev/null +++ b/structs.rkt @@ -0,0 +1,96 @@ +#lang racket/base + +(provide (all-defined-out)) + +;; (define-type Orientation (U 'publisher 'subscriber)) + +(struct role (orientation ;; Orientation + topic ;; Topic + interest-type ;; InterestType + ) + #:transparent) + +;; (define-type Message Topic) ;; Cheesy. + +;; (define-type InterestType (U 'participant 'observer 'everything)) + +;; (define-type (Handler State) (TrapK EndpointEvent State)) + +;; (define-type (InterruptK State) (State -> (Transition State))) +;; (define-type (TrapK Event State) (Event -> (InterruptK State))) + +;; (define-type EndpointEvent (U PresenceEvent +;; AbsenceEvent +;; MessageEvent)) + +(struct presence-event (role) #:transparent) +(struct absence-event (role reason) #:transparent) +(struct message-event (role message) #:transparent) + +(struct transition (state ;; State + actions ;; (ActionTree State) + ) + #:transparent) + +;; (define-type (ActionTree State) (Constreeof (Action State))) + +;; Existential quantification over State +;; (define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result)) + +;; Specification of a new process +(struct process-spec (boot ;; (PID -> CoTransition) + ) + #:transparent) +;; (define-type ProcessSpec process-spec) + +;; (define-type (PreAction State) (U (add-endpoint State) +;; delete-endpoint +;; send-message +;; (spawn State) +;; quit)) + +(struct add-endpoint (pre-eid ;; PreEID + role ;; Role + handler ;; (Handler State) + ) + #:transparent) + +(struct delete-endpoint (pre-eid ;; PreEID + reason ;; Reason + ) + #:transparent) + +(struct send-message (body ;; Message + orientation ;; Orientation + ) + #:transparent) + +(struct spawn (spec ;; process-spec + k ;; (Option (PID -> (InterruptK State))) + debug-name ;; Any + ) + #:transparent) + +(struct quit (pid ;; (Option PID) ;; #f = suicide + reason ;; Reason + ) + #:transparent) + +;; (define-type (Action State) (U (PreAction State) +;; (yield State) +;; (at-meta-level State))) + +(struct yield (k ;; (InterruptK State) + ) + #:transparent) + +(struct at-meta-level (preaction ;; (PreAction State) + ) + #:transparent) + +;; (define-type PID Number) + +;;; Local Variables: +;;; eval: (put 'transition 'scheme-indent-function 1) +;;; eval: (put 'transition/no-state 'scheme-indent-function 0) +;;; End: diff --git a/sugar-endpoints-support.rkt b/sugar-endpoints-support.rkt deleted file mode 100644 index 041f1c5..0000000 --- a/sugar-endpoints-support.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#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]) diff --git a/sugar-endpoints-typed.rkt b/sugar-endpoints-typed.rkt deleted file mode 100644 index 456625a..0000000 --- a/sugar-endpoints-typed.rkt +++ /dev/null @@ -1,247 +0,0 @@ -#lang typed/racket/base - -(require (for-syntax syntax/parse)) -(require (for-syntax racket/base)) - -(require racket/match) - -(require (prefix-in core: "main.rkt")) - -(require "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: diff --git a/sugar-typed.rkt b/sugar-typed.rkt deleted file mode 100644 index 708fa21..0000000 --- a/sugar-typed.rkt +++ /dev/null @@ -1,133 +0,0 @@ -#lang typed/racket/base - -(require (for-syntax syntax/parse)) -(require (for-syntax racket/base)) - -(require racket/match) -(require (prefix-in core: "main.rkt")) -(require (except-in "main.rkt" - at-meta-level - spawn - yield - transition - delete-endpoint - send-message - quit - wild)) -(require "sugar-values.rkt") -(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: diff --git a/sugar-untyped.rkt b/sugar-untyped.rkt deleted file mode 100644 index 269d80e..0000000 --- a/sugar-untyped.rkt +++ /dev/null @@ -1,113 +0,0 @@ -#lang racket/base - -(require (for-syntax syntax/parse)) -(require (for-syntax racket/base)) - -(require racket/match) -(require (prefix-in core: "main.rkt")) -(require (except-in "main.rkt" - at-meta-level - spawn - yield - transition - delete-endpoint - send-message - quit)) -(require "sugar-values.rkt") -(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: diff --git a/sugar-values.rkt b/sugar-values.rkt deleted file mode 100644 index 17554c6..0000000 --- a/sugar-values.rkt +++ /dev/null @@ -1,80 +0,0 @@ -#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: diff --git a/sugar-endpoints-untyped.rkt b/sugar.rkt similarity index 59% rename from sugar-endpoints-untyped.rkt rename to sugar.rkt index e3f03df..c952667 100644 --- a/sugar-endpoints-untyped.rkt +++ b/sugar.rkt @@ -4,12 +4,25 @@ (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") -(require "sugar-endpoints-support.rkt") +(provide 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 @@ -18,7 +31,71 @@ 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 @@ -215,7 +292,88 @@ (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) diff --git a/support/debug.rkt b/support/debug.rkt index b2f502a..2a186dc 100644 --- a/support/debug.rkt +++ b/support/debug.rkt @@ -1,60 +1,56 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) (require (prefix-in core: "../main.rkt")) -(require "../sugar-typed.rkt") +(require "../sugar.rkt") (require "../vm.rkt") (require "../process.rkt") (require "../quasiqueue.rkt") -(require/typed "gui.rkt" - [open-debugger (Any -> Debugger)]) +(require "gui.rkt") -(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 - (process-spec - (lambda: ([pid : PID]) ;; TODO: exploit this more in messages etc. - (define original-cotransition ((process-spec-boot child-spec) pid)) - (: wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R)) + (core:process-spec + (lambda (pid) ;; TODO: exploit this more in messages etc. + (define original-cotransition ((core:process-spec-boot child-spec) pid)) + ;; wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R) (define (wrapped-cotransition k) - (: receiver : (All (S) (Transition S) -> R)) + ;; receiver : (All (S) (Transition S) -> R) (define (receiver child-transition) (define d (open-debugger debug-name)) - ((inst k S) (wrap-transition d child-transition))) - ((inst original-cotransition R) receiver)) + (k (wrap-transition d child-transition))) + (original-cotransition receiver)) wrapped-cotransition)) parent-k (list 'debug debug-name))) -(: wrap-transition : (All (ChildState) - Debugger - (Transition ChildState) - -> (Transition ChildState))) +;; wrap-transition : (All (ChildState) +;; Debugger +;; (Transition ChildState) +;; -> (Transition ChildState)) (define (wrap-transition d child-transition0) - (define child-transition ((inst d (Transition ChildState)) child-transition0)) + (define child-transition (d child-transition0)) (match-define (core:transition child-state child-actions) child-transition) - (core:transition child-state ((inst action-tree-map ChildState) - (wrap-action d) - child-actions))) + (core:transition child-state (action-tree-map (wrap-action d) + child-actions))) -(: action-tree-map : (All (State) ((Action State) -> (Action State)) - (ActionTree State) - -> (ActionTree State))) +;; action-tree-map : (All (State) ((Action State) -> (Action State)) +;; (ActionTree State) +;; -> (ActionTree State)) (define (action-tree-map f actions) - ((inst map (Action State) (Action State)) - f - (quasiqueue->list (action-tree->quasiqueue actions)))) + (map f (quasiqueue->list (action-tree->quasiqueue actions)))) -(: wrap-action : (All (ChildState) - Debugger - -> ((Action ChildState) -> (Action ChildState)))) +;; wrap-action : (All (ChildState) +;; Debugger +;; -> ((Action ChildState) -> (Action ChildState))) (define ((wrap-action d) action) (cond [(core:yield? action) @@ -64,11 +60,11 @@ [else (wrap-preaction #f d action)])) -(: wrap-preaction : (All (ChildState) - Boolean - Debugger - (PreAction ChildState) - -> (PreAction ChildState))) +;; wrap-preaction : (All (ChildState) +;; Boolean +;; Debugger +;; (PreAction ChildState) +;; -> (PreAction ChildState)) (define (wrap-preaction meta? d preaction) (match preaction [(core:add-endpoint pre-eid role handler) @@ -82,28 +78,28 @@ [(core:quit pid reason) preaction])) -(: wrap-interruptk : (All (ChildState) - Debugger - (InterruptK ChildState) - -> (InterruptK ChildState))) +;; wrap-interruptk : (All (ChildState) +;; Debugger +;; (InterruptK ChildState) +;; -> (InterruptK ChildState)) (define (wrap-interruptk d ik) (lambda (state) (wrap-transition d (ik state)))) -(: wrap-spawnk : (All (ChildState) - Debugger - (Option (PID -> (InterruptK ChildState))) - -> (Option (PID -> (InterruptK ChildState))))) +;; wrap-spawnk : (All (ChildState) +;; Debugger +;; (Option (PID -> (InterruptK ChildState))) +;; -> (Option (PID -> (InterruptK ChildState)))) (define (wrap-spawnk d maybe-k) (and maybe-k - (lambda: ([child-pid : PID]) (wrap-interruptk d (maybe-k child-pid))))) + (lambda (child-pid) (wrap-interruptk d (maybe-k child-pid))))) -(: wrap-handler : (All (ChildState) - Boolean - Debugger - (Handler ChildState) - -> (Handler ChildState))) +;; wrap-handler : (All (ChildState) +;; Boolean +;; Debugger +;; (Handler ChildState) +;; -> (Handler ChildState)) (define (wrap-handler meta?0 d h) (lambda (event0) - (match-define (cons meta? event) ((inst d (Pairof Boolean EndpointEvent)) (cons meta?0 event0))) + (match-define (cons meta? event) (d (cons meta?0 event0))) (wrap-interruptk d (h event)))) diff --git a/support/event.rkt b/support/event.rkt deleted file mode 100644 index 5f3c69b..0000000 --- a/support/event.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang typed/racket/base - -(require/typed typed/racket/base - [opaque Evt evt?]) - -(provide Evt - evt?) diff --git a/support/gui.rkt b/support/gui.rkt index d0c0560..cb340f7 100644 --- a/support/gui.rkt +++ b/support/gui.rkt @@ -19,7 +19,7 @@ (require racket/pretty) -(require (prefix-in core: "../types.rkt") +(require (prefix-in core: "../structs.rkt") (prefix-in core: "../vm.rkt")) (provide open-debugger) diff --git a/support/pseudo-substruct.rkt b/support/pseudo-substruct.rkt deleted file mode 100644 index 34cba6e..0000000 --- a/support/pseudo-substruct.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang typed/racket/base -;; Limited support for reasoning about subtyped of a polymorphic base struct type in TR. - -(require (for-syntax racket/base)) -(require racket/match) - -(provide pseudo-substruct:) - -(define-syntax-rule (pseudo-substruct: (super-type TypeParam ...) SubType sub-type sub-type?) - (begin (define-type SubType (super-type TypeParam ...)) - (define-predicate sub-type? SubType) - (define-match-expander sub-type - (lambda (stx) - (syntax-case stx () [(_ f (... ...)) #'(? sub-type? (super-type f (... ...)))])) - (lambda (stx) - (syntax-case stx () - [x (identifier? #'x) #'(inst super-type TypeParam ...)] - [(_ f (... ...)) #'((inst super-type TypeParam ...) f (... ...))]))))) diff --git a/support/spy.rkt b/support/spy.rkt index 839a955..0585ad0 100644 --- a/support/spy.rkt +++ b/support/spy.rkt @@ -1,32 +1,30 @@ -#lang typed/racket/base +#lang racket/base -(require "../sugar-typed.rkt") +(require "../sugar.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: #:parent : ParentState - #:child : Void - (transition: (void) : Void - (observe-publishers: Void (wild) - (match-orientation orientation - (match-conversation topic - (match-interest-type interest - (match-reason reason - (on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest))) - (newline) - (flush-output) - '())) - (on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest))) - (newline) - (display reason) + (spawn (transition (void) + (observe-publishers (wild) + (match-orientation orientation + (match-conversation topic + (match-interest-type interest + (match-reason reason + (on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest))) (newline) (flush-output) '())) - (on-message - [p (begin (write `(,label MSG ,p)) - (newline) - (flush-output) - '())])))))))))) + (on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest))) + (newline) + (display reason) + (newline) + (flush-output) + '())) + (on-message + [p (begin (write `(,label MSG ,p)) + (newline) + (flush-output) + '())])))))))))) diff --git a/test-struct-map-typed.rkt b/test-struct-map-typed.rkt deleted file mode 100644 index b087e19..0000000 --- a/test-struct-map-typed.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang typed/racket/base - -(require typed/rackunit) - -(require/typed "struct-map.rkt" - [struct-map ((Any -> Any) Any -> Any)]) -(require/typed "test-struct-map.rkt" - [#:struct foo ([bar : Integer] - [zot : Integer])]) - -(check-equal? (struct-map (lambda (x) (if (equal? x 123) 999 888)) (foo 123 234)) - (foo 999 234)) diff --git a/tr-struct-copy.rkt b/tr-struct-copy.rkt deleted file mode 100644 index cfa4952..0000000 --- a/tr-struct-copy.rkt +++ /dev/null @@ -1,166 +0,0 @@ -#lang racket/base -;; Revolting hacked-on struct-copy using unhygienic-identifier=? -;; instead of free-identifier=? to compare accessor names, to get -;; around the contracting of accessors exported from TR modules. -;; -;; Workaround for PR13149. - -(require (for-syntax racket/base racket/private/struct-info)) - -(provide tr-struct-copy) - -(define-for-syntax (unhygienic-identifier=? a b) - (eq? (syntax->datum a) - (syntax->datum b))) - -(define-syntax (tr-struct-copy stx) - (if (not (eq? (syntax-local-context) 'expression)) - (quasisyntax/loc stx (#%expression #,stx)) - (syntax-case stx () - [(form-name info struct-expr field+val ...) - (let ([ans (syntax->list #'(field+val ...))]) - ;; Check syntax: - (unless (identifier? #'info) - (raise-syntax-error #f "not an identifier for structure type" stx #'info)) - (for-each (lambda (an) - (syntax-case an () - [(field val) - (unless (identifier? #'field) - (raise-syntax-error #f - "not an identifier for field name" - stx - #'field))] - [(field #:parent p val) - (unless (identifier? #'field) - (raise-syntax-error #f - "not an identifier for field name" - stx - #'field)) - (unless (identifier? #'p) - (raise-syntax-error #f - "not an identifier for parent struct name" - stx - #'field))] - [_ - (raise-syntax-error #f - (string-append - "bad syntax;\n" - " expected a field update of the form ( )\n" - " or ( #:parent )") - 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)))))))]))) diff --git a/types.rkt b/types.rkt deleted file mode 100644 index 5fed8ac..0000000 --- a/types.rkt +++ /dev/null @@ -1,119 +0,0 @@ -#lang typed/racket/base - -(require "quasiqueue.rkt") - -(require/typed "opaque-any.rkt" - ;; Various opaque "Any"s - [opaque Topic topic?] - [opaque PreEID pre-eid?] - [opaque Reason reason?]) - -(provide (all-defined-out) - (all-from-out "quasiqueue.rkt")) - -;; This module uses different terminology to os2.rkt. From the paper: -;; "A role generalizes traditional notions of advertisement and -;; subscription by combining a topic of conversation with a direction: -;; either publisher or subscriber. An endpoint combines a role with -;; handlers for events relating to the conversation" - -(define-type Orientation (U 'publisher 'subscriber)) - -(struct: role ([orientation : Orientation] - [topic : Topic] - [interest-type : InterestType]) - #:transparent) -(define-type Role role) - -(define-type Message Topic) ;; Cheesy. - -(define-type InterestType (U 'participant 'observer 'everything)) - -(define-type (Handler State) (TrapK EndpointEvent State)) - -(define-type (InterruptK State) (State -> (Transition State))) -(define-type (TrapK Event State) (Event -> (InterruptK State))) - -(define-type EndpointEvent (U PresenceEvent - AbsenceEvent - MessageEvent)) - -(struct: presence-event ([role : Role]) #:transparent) -(struct: absence-event ([role : Role] [reason : Reason]) #:transparent) -(struct: message-event ([role : Role] [message : Message]) #:transparent) -(define-type PresenceEvent presence-event) -(define-type AbsenceEvent absence-event) -(define-type MessageEvent message-event) - -(struct: (State) - transition ([state : State] - [actions : (ActionTree State)]) - #:transparent) -(define-type (Transition State) (transition State)) - -(define-type (ActionTree State) (Constreeof (Action State))) - -;; Existential quantification over State -(define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result)) - -;; Specification of a new process -(struct: process-spec ([boot : (PID -> CoTransition)]) - #:transparent) -(define-type ProcessSpec process-spec) - -(define-type (PreAction State) (U (add-endpoint State) - delete-endpoint - send-message - (spawn State) - quit)) - -(struct: (State) - add-endpoint ([pre-eid : PreEID] - [role : Role] - [handler : (Handler State)]) - #:transparent) -(define-type (AddEndpoint State) (add-endpoint State)) - -(struct: delete-endpoint ([pre-eid : PreEID] - [reason : Reason]) - #:transparent) -(define-type DeleteEndpoint delete-endpoint) - -(struct: send-message ([body : Message] - [orientation : Orientation]) - #:transparent) -(define-type SendMessage send-message) - -(struct: (State) - spawn ([spec : process-spec] - [k : (Option (PID -> (InterruptK State)))] - [debug-name : Any]) - #:transparent) -(define-type (Spawn State) (spawn State)) - -(struct: quit ([pid : (Option PID)] ;; #f = suicide - [reason : Reason]) - #:transparent) -(define-type Quit quit) - -(define-type (Action State) (U (PreAction State) - (yield State) - (at-meta-level State))) - -(struct: (State) - yield ([k : (InterruptK State)]) - #:transparent) -(define-type (Yield State) (yield State)) - -(struct: (State) - at-meta-level ([preaction : (PreAction State)]) - #:transparent) -(define-type (AtMetaLevel State) (at-meta-level State)) - -(define-type PID Number) - -;;; Local Variables: -;;; eval: (put 'transition 'scheme-indent-function 1) -;;; eval: (put 'transition: 'scheme-indent-function 3) -;;; eval: (put 'transition/no-state 'scheme-indent-function 0) -;;; End: diff --git a/vm.rkt b/vm.rkt index cf74cc7..d576f1d 100644 --- a/vm.rkt +++ b/vm.rkt @@ -1,22 +1,18 @@ -#lang typed/racket/base +#lang racket/base (require racket/match) -(require "types.rkt") +(require "structs.rkt") (require "roles.rkt") -(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround +(require "quasiqueue.rkt") (provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161) vm-next-process-id - vm ;; really just want to export the type here, not the ctor + vm vm? (struct-out process) (struct-out endpoint) (struct-out eid) - Process - CoProcess - mkProcess - unwrap-process make-vm inject-process @@ -26,79 +22,53 @@ process-map endpoint-fold) -(struct: vm ([processes : (HashTable PID Process)] - [next-process-id : PID]) - #:transparent) +(struct vm (processes ;; (HashTable PID Process) + next-process-id ;; PID + ) + #:transparent) -(struct: (State) - process ([debug-name : Any] - [pid : PID] - [state : State] - [spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm - [endpoints : (HashTable PreEID (endpoint State))] - [meta-endpoints : (HashTable PreEID (endpoint State))] - [pending-actions : (QuasiQueue (Action State))]) - #:transparent) +(struct process (debug-name ;; Any + pid ;; PID + state ;; State + spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm + endpoints ;; (HashTable PreEID (endpoint State)) + meta-endpoints ;; (HashTable PreEID (endpoint State)) + pending-actions ;; (QuasiQueue (Action State)) + ) + #:transparent) -(struct: (State) - endpoint ([id : eid] - [role : role] - [handler : (Handler State)]) - #:transparent) +(struct endpoint (id ;; eid + role ;; role + handler ;; (Handler State) + ) + #:transparent) -(struct: eid ([pid : PID] - [pre-eid : PreEID]) - #:transparent) - -(define-type Process (All (R) (CoProcess R) -> R)) -(define-type (CoProcess R) (All (State) (process State) -> R)) - -(: mkProcess : (All (State) ((CoProcess Process) State))) -;; A kind of identity function, taking the components of a process to -;; a process. -(define (mkProcess p) - (lambda (k) ((inst k State) p))) - -(: Process-pid : Process -> PID) -(define (Process-pid wp) ((inst wp PID) process-pid)) - -;; Unwraps a process. Result is the type of the result of the -;; expression; State is a type variable to be bound to the process's -;; private state type. p is to be bound to the unwrapped process; wp -;; is the expression producing the wrapped process. body... are the -;; forms computing a value of type Result. -(define-syntax-rule (unwrap-process State Result (p wp) body ...) - (let () - (: coproc : (All (State) (process State) -> Result)) - (define (coproc p) - body ...) - ((inst wp Result) coproc))) +(struct eid (pid ;; PID + pre-eid ;; PreEID + ) + #:transparent) ;;--------------------------------------------------------------------------- -(: make-vm : process-spec -> vm) +;; make-vm : process-spec -> vm (define (make-vm boot) - (define primordial (mkProcess ((inst process Void) - '#:primordial - -1 - (void) - (list) - #hash() - #hash() - (quasiqueue ((inst spawn Void) boot #f '#:boot-process))))) - (vm (hash-set (ann #hash() (HashTable PID Process)) - (Process-pid primordial) - primordial) - 0)) + (define primordial (process '#:primordial + -1 + (void) + (list) + #hash() + #hash() + (quasiqueue (spawn boot #f '#:boot-process)))) + (vm (hash-set #hash() (process-pid primordial) primordial) 0)) -(: inject-process : vm Process -> vm) +;; 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 @@ -106,29 +76,28 @@ 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 ((inst empty-quasiqueue (Action State)))])) + (struct-copy process p [pending-actions (empty-quasiqueue)])) -(: 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 - (unwrap-process State vm (p wp) - (inject-process state (mkProcess (f p)))))))) + (inject-process state (f wp)))))) -(: 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 - (unwrap-process State A (p wp) - (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))]) - (define ep (hash-ref (process-endpoints p) pre-eid)) - ((inst f State) p ep seed))))))) + (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))]) + (define ep (hash-ref (process-endpoints wp) pre-eid)) + (f wp ep seed)))))) ;;; Local Variables: ;;; eval: (put 'unwrap-process 'scheme-indent-function 3)