diff --git a/marketplace/drivers/event-relay.rkt b/marketplace/drivers/event-relay.rkt index 1747273..e18fc30 100644 --- a/marketplace/drivers/event-relay.rkt +++ b/marketplace/drivers/event-relay.rkt @@ -7,27 +7,24 @@ (: event-relay : (All (ParentState) Symbol -> (Spawn ParentState))) (define (event-relay self-id) - (spawn: #:debug-name `(event-relay ,self-id) - #:parent : ParentState - #:child : Void - (transition/no-state - (endpoint: : Void - #:publisher (cons ? ?) #:observer - #:conversation (cons (? evt? e) _) - #:on-presence (begin - (printf "SUBSCRIBED ~v~n" e) - (flush-output) - (at-meta-level - (endpoint: : Void - #:subscriber (cons e ?) - #:name `(event-relay ,self-id ,e) - [msg - (begin - (printf "FIRED ~v -> ~v~n" e msg) - (flush-output) - (send-message msg))]))) - #:on-absence (begin - (printf "UNSUBSCRIBED ~v~n" e) - (flush-output) - (at-meta-level - (delete-endpoint `(event-relay ,self-id ,e)))))))) + (name-process `(event-relay ,self-id) + (spawn: #:parent : ParentState + #:child : Void + (transition/no-state + (observe-publishers: 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) + (subscribe-to-topic: Void (cons e ?) + (on-message + [msg (begin (printf "FIRED ~v -> ~v~n" e msg) + (flush-output) + (send-message msg))])))))) + (on-absence (begin + (printf "UNSUBSCRIBED ~v~n" e) + (flush-output) + (at-meta-level: Void + (delete-endpoint `(event-relay ,self-id ,e))))))))))) diff --git a/marketplace/drivers/tcp-bare.rkt b/marketplace/drivers/tcp-bare.rkt index 5b4e336..223a72c 100644 --- a/marketplace/drivers/tcp-bare.rkt +++ b/marketplace/drivers/tcp-bare.rkt @@ -26,50 +26,52 @@ (define any-listener (tcp-listener (wild))) (define (tcp-driver) - (spawn #:debug-name 'tcp-driver - #:child - (transition (set) - (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:publisher (tcp-channel any-remote any-listener (wild)) #:everything - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:publisher (tcp-channel any-remote any-handle (wild)) #:observer - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager) - #:on-absence (maybe-forget-socket r active-handles))))) + (name-process 'tcp-driver + (spawn + (transition (set) + (observe-publishers/everything (tcp-channel any-listener any-remote (wild)) + (match-state active-handles + (match-conversation c + (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager)) + (on-absence (maybe-forget-socket 'publisher c active-handles))))) + (observe-subscribers/everything (tcp-channel any-remote any-listener (wild)) + (match-state active-handles + (match-conversation c + (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager)) + (on-absence (maybe-forget-socket 'subscriber c active-handles))))) + (observe-publishers (tcp-channel any-handle any-remote (wild)) + (match-state active-handles + (match-conversation c + (on-presence + (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager)) + (on-absence (maybe-forget-socket 'publisher c active-handles))))) + (observe-subscribers (tcp-channel any-handle any-remote (wild)) + (match-state active-handles + (match-conversation c + (on-presence + (maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager)) + (on-absence (maybe-forget-socket 'subscriber c active-handles))))))))) (define tcp (tcp-driver)) ;; pre-instantiated! -(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun) - (match r - [(or (role 'publisher (tcp-channel local-addr remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr local-addr _) _)) +(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun) + (match (list orientation c) + [(or (list 'publisher (tcp-channel local-addr remote-addr _)) + (list 'subscriber (tcp-channel remote-addr local-addr _))) (cond [(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)] [(not (ground? local-addr)) (transition active-handles)] [(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)] [else (transition (set-add active-handles (cons local-addr remote-addr)) - (spawn #:debug-name (cons local-addr remote-addr) - #:child (driver-fun local-addr remote-addr)))])])) + (name-process (cons local-addr remote-addr) + (spawn (driver-fun local-addr remote-addr))))])])) -;; Role Set -> Transition -(define (maybe-forget-socket r active-handles) - (match r - [(or (role 'publisher (tcp-channel local-addr remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr local-addr _) _)) +;; Orientation Topic Set -> Transition +(define (maybe-forget-socket orientation c active-handles) + (match (list orientation c) + [(or (list 'publisher (tcp-channel local-addr remote-addr _)) + (list 'subscriber (tcp-channel remote-addr local-addr _))) (cond [(ground? remote-addr) (transition active-handles)] [(not (ground? local-addr)) (transition active-handles)] @@ -80,40 +82,40 @@ (match-define (tcp-listener port) local-addr) (define listener (tcp:tcp-listen port 4 #t)) - (define (handle-absence r state) + (define (handle-absence orientation c state) ;; Hey, what if the presence we need went away between our manager ;; spawning us, and us getting to this point? Presence being ;; "edge-" rather than "level-triggered" means we'll hang around ;; sadly forever, accepting connections to nowhere. TODO - (match r - [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr (== local-addr) _) _)) + (match (list orientation c) + [(or (list 'publisher (tcp-channel (== local-addr) remote-addr _)) + (list 'subscriber (tcp-channel remote-addr (== local-addr) _))) (if (ground? remote-addr) (transition state) (transition 'listener-is-closed (quit) (when (eq? state 'listener-is-running) - (spawn #:debug-name (list 'tcp-listener-closer local-addr) - #:child - (begin (tcp:tcp-close listener) - (transition 'dummy (quit)))))))])) + (name-process (list 'tcp-listener-closer local-addr) + (spawn (begin (tcp:tcp-close listener) + (transition 'dummy (quit))))))))])) (transition 'listener-is-running - (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything - #:state state - #:role r - #:on-absence (handle-absence r state)) - (endpoint #:publisher (tcp-channel any-remote local-addr (wild)) #:everything - #:state state - #:role r - #:on-absence (handle-absence r state)) - (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild)) - [(cons _ (list cin cout)) - (let-values (((local-hostname local-port remote-hostname remote-port) - (tcp:tcp-addresses cin #t))) - (define remote-addr (tcp-address remote-hostname remote-port)) - (spawn #:debug-name (cons local-addr remote-addr) - #:child (tcp-connection-manager* local-addr remote-addr cin cout)))]))) + (observe-publishers/everything (tcp-channel local-addr any-remote (wild)) + (match-state state + (match-conversation c + (on-absence (handle-absence 'publisher c state))))) + (observe-subscribers/everything (tcp-channel any-remote local-addr (wild)) + (match-state state + (match-conversation c + (on-absence (handle-absence 'subscriber c state))))) + (subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild)) + (on-message + [(cons _ (list cin cout)) + (let-values (((local-hostname local-port remote-hostname remote-port) + (tcp:tcp-addresses cin #t))) + (define remote-addr (tcp-address remote-hostname remote-port)) + (name-process (cons local-addr remote-addr) + (spawn (tcp-connection-manager* local-addr remote-addr cin cout))))])))) ;; TcpAddress TcpAddress -> Transition (define (tcp-connection-manager local-addr remote-addr) @@ -142,33 +144,35 @@ (when is-open (list (when send-eof? (send-message (tcp-channel remote-addr local-addr eof))) - (spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr) - #:child - (begin (tcp:tcp-abandon-port cin) - (tcp:tcp-abandon-port cout) - (transition/no-state (quit)))))) + (name-process (list 'tcp-connection-closer local-addr remote-addr) + (spawn (begin (tcp:tcp-abandon-port cin) + (tcp:tcp-abandon-port cout) + (transition/no-state (quit))))))) (quit))) (transition #t ;; open - (endpoint #:subscriber (cons (read-bytes-avail-evt 4096 cin) (wild)) - #:state is-open - [(cons _ (? eof-object?)) (close-transition is-open #t)] - [(cons _ (? bytes? bs)) (transition is-open (send-message (tcp-channel remote-addr local-addr bs)))]) - (endpoint #:subscriber (cons (eof-evt cin) (wild)) - #:state is-open - [(cons (? evt?) _) (close-transition is-open #t)]) - (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild)) - #:state is-open - #:on-absence (close-transition is-open #f) - [(tcp-channel (== local-addr) (== remote-addr) subpacket) - (match subpacket - [(? eof-object?) (close-transition is-open #f)] - [(? string? s) (begin (write-string s cout) - (flush-output cout) - (transition is-open))] - [(? bytes? bs) (begin (write-bytes bs cout) - (flush-output cout) - (transition is-open))])]) - (endpoint #:publisher (tcp-channel remote-addr local-addr (wild)) - #:state is-open - #:on-absence (close-transition is-open #f)))) + (subscribe-to-topic (cons (read-bytes-avail-evt 4096 cin) (wild)) + (match-state is-open + (on-message + [(cons _ (? eof-object?)) (close-transition is-open #t)] + [(cons _ (? bytes? bs)) (transition is-open + (send-message (tcp-channel remote-addr local-addr bs)))]))) + (subscribe-to-topic (cons (eof-evt cin) (wild)) + (match-state is-open + (on-message [(cons (? evt?) _) (close-transition is-open #t)]))) + (subscribe-to-topic (tcp-channel local-addr remote-addr (wild)) + (match-state is-open + (on-absence (close-transition is-open #f)) + (on-message + [(tcp-channel (== local-addr) (== remote-addr) subpacket) + (match subpacket + [(? eof-object?) (close-transition is-open #f)] + [(? string? s) (begin (write-string s cout) + (flush-output cout) + (transition is-open))] + [(? bytes? bs) (begin (write-bytes bs cout) + (flush-output cout) + (transition is-open))])]))) + (publish-on-topic (tcp-channel remote-addr local-addr (wild)) + (match-state is-open + (on-absence (close-transition is-open #f)))))) diff --git a/marketplace/drivers/tcp.rkt b/marketplace/drivers/tcp.rkt index 265d0d7..7a5d9d4 100644 --- a/marketplace/drivers/tcp.rkt +++ b/marketplace/drivers/tcp.rkt @@ -81,49 +81,51 @@ ;; Spawn ;; Process acting as a TCP socket factory. (define (tcp-driver) - (spawn #:debug-name 'tcp-driver - #:child - (transition (set) - (endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:publisher (tcp-channel any-remote any-listener (wild)) #:everything - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager) - #:on-absence (maybe-forget-socket r active-handles)) - (endpoint #:publisher (tcp-channel any-remote any-handle (wild)) #:observer - #:state active-handles - #:role r - #:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager) - #:on-absence (maybe-forget-socket r active-handles))))) + (name-process 'tcp-driver + (spawn + (transition (set) + (observe-publishers/everything (tcp-channel any-listener any-remote (wild)) + (match-state active-handles + (match-conversation c + (on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager)) + (on-absence (maybe-forget-socket 'publisher c active-handles))))) + (observe-subscribers/everything (tcp-channel any-remote any-listener (wild)) + (match-state active-handles + (match-conversation c + (on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager)) + (on-absence (maybe-forget-socket 'subscriber c active-handles))))) + (observe-publishers (tcp-channel any-handle any-remote (wild)) + (match-state active-handles + (match-conversation c + (on-presence + (maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager)) + (on-absence (maybe-forget-socket 'publisher c active-handles))))) + (observe-subscribers (tcp-channel any-remote any-handle (wild)) + (match-state active-handles + (match-conversation c + (on-presence + (maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager)) + (on-absence (maybe-forget-socket 'subscriber c active-handles))))))))) -;; Role Set Boolean (TcpAddress TcpAddress -> BootK) -> Transition -(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun) - (match r - [(or (role 'publisher (tcp-channel local-addr remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr local-addr _) _)) +;; Orientation Topic Set Boolean (TcpAddress TcpAddress -> BootK) -> Transition +(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun) + (match (list orientation c) + [(or (list 'publisher (tcp-channel local-addr remote-addr _)) + (list 'subscriber (tcp-channel remote-addr local-addr _))) (cond [(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)] [(not (ground? local-addr)) (transition active-handles)] [(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)] [else (transition (set-add active-handles (cons local-addr remote-addr)) - (spawn #:debug-name (cons local-addr remote-addr) - #:child (driver-fun local-addr remote-addr)))])])) + (name-process (cons local-addr remote-addr) + (spawn (driver-fun local-addr remote-addr))))])])) -;; Role Set -> Transition -(define (maybe-forget-socket r active-handles) - (match r - [(or (role 'publisher (tcp-channel local-addr remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr local-addr _) _)) +;; Orientation Topic Set -> Transition +(define (maybe-forget-socket orientation c active-handles) + (match (list orientation c) + [(or (list 'publisher (tcp-channel local-addr remote-addr _)) + (list 'subscriber (tcp-channel remote-addr local-addr _))) (cond [(ground? remote-addr) (transition active-handles)] [(not (ground? local-addr)) (transition active-handles)] @@ -134,40 +136,40 @@ (match-define (tcp-listener port) local-addr) (define listener (tcp:tcp-listen port 4 #t)) - (define (handle-absence r state) + (define (handle-absence orientation c state) ;; Hey, what if the presence we need went away between our manager ;; spawning us, and us getting to this point? Presence being ;; "edge-" rather than "level-triggered" means we'll hang around ;; sadly forever, accepting connections to nowhere. TODO - (match r - [(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _) - (role 'subscriber (tcp-channel remote-addr (== local-addr) _) _)) + (match (list orientation c) + [(or (list 'publisher (tcp-channel (== local-addr) remote-addr _)) + (list 'subscriber (tcp-channel remote-addr (== local-addr) _))) (if (ground? remote-addr) (transition state) (transition 'listener-is-closed (quit) (when (eq? state 'listener-is-running) - (spawn #:debug-name (list 'tcp-listener-closer local-addr) - #:child - (begin (tcp:tcp-close listener) - (transition 'dummy (quit)))))))])) + (name-process (list 'tcp-listener-closer local-addr) + (spawn (begin (tcp:tcp-close listener) + (transition 'dummy (quit))))))))])) (transition 'listener-is-running - (endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything - #:state state - #:role r - #:on-absence (handle-absence r state)) - (endpoint #:publisher (tcp-channel any-remote local-addr (wild)) #:everything - #:state state - #:role r - #:on-absence (handle-absence r state)) - (endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild)) - [(cons _ (list cin cout)) - (let-values (((local-hostname local-port remote-hostname remote-port) - (tcp:tcp-addresses cin #t))) - (define remote-addr (tcp-address remote-hostname remote-port)) - (spawn #:debug-name (cons local-addr remote-addr) - #:child (tcp-connection-manager* local-addr remote-addr cin cout)))]))) + (observe-publishers/everything (tcp-channel local-addr any-remote (wild)) + (match-state state + (match-conversation c + (on-absence (handle-absence 'publisher c state))))) + (observe-subscribers/everything (tcp-channel any-remote local-addr (wild)) + (match-state state + (match-conversation c + (on-absence (handle-absence 'subscriber c state))))) + (subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild)) + (on-message + [(cons _ (list cin cout)) + (let-values (((local-hostname local-port remote-hostname remote-port) + (tcp:tcp-addresses cin #t))) + (define remote-addr (tcp-address remote-hostname remote-port)) + (name-process (cons local-addr remote-addr) + (spawn (tcp-connection-manager* local-addr remote-addr cin cout))))])))) ;; TcpAddress TcpAddress -> Transition (define (tcp-connection-manager local-addr remote-addr) @@ -185,11 +187,10 @@ (when (not (eq? state #f)) (list (when send-eof? (send-message (tcp-channel remote-addr local-addr eof))) - (spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr) - #:child - (begin (tcp:tcp-abandon-port cin) - (tcp:tcp-abandon-port cout) - (transition 'dummy (quit)))))) + (name-process (list 'tcp-connection-closer local-addr remote-addr) + (spawn(begin (tcp:tcp-abandon-port cin) + (tcp:tcp-abandon-port cout) + (transition 'dummy (quit))))))) (quit))) (define (adjust-credit state amount) (let ((new-credit (+ (tcp-connection-state-credit state) amount))) @@ -198,56 +199,62 @@ (when (positive? new-credit) (case (tcp-connection-state-mode state) [(lines) - (endpoint #:subscriber (cons (read-bytes-line-evt cin 'any) (wild)) - #:name 'inbound-relay - #:state state - [(cons _ (? eof-object?)) - (close-transition state #t)] - [(cons _ (? bytes? bs)) - (sequence-actions (adjust-credit state -1) - (send-message (tcp-channel remote-addr local-addr bs)))])] + (name-endpoint 'inbound-relay + (subscribe-to-topic (cons (read-bytes-line-evt cin 'any) (wild)) + (match-state state + (on-message + [(cons _ (? eof-object?)) + (close-transition state #t)] + [(cons _ (? bytes? bs)) + (sequence-actions (adjust-credit state -1) + (send-message (tcp-channel remote-addr local-addr bs)))]))))] [(bytes) - (endpoint #:subscriber (cons (read-bytes-evt new-credit cin) (wild)) - #:name 'inbound-relay - #:state state - [(cons _ (? eof-object?)) - (close-transition state #t)] - [(cons _ (? bytes? bs)) - (let ((len (bytes-length bs))) - (sequence-actions (adjust-credit state (- len)) - (send-message (tcp-channel remote-addr local-addr bs))))])]))))) + (name-endpoint 'inbound-relay + (subscribe-to-topic (cons (read-bytes-evt new-credit cin) (wild)) + (match-state state + (on-message + [(cons _ (? eof-object?)) + (close-transition state #t)] + [(cons _ (? bytes? bs)) + (let ((len (bytes-length bs))) + (sequence-actions (adjust-credit state (- len)) + (send-message + (tcp-channel remote-addr local-addr bs))))]))))]))))) (transition (tcp-connection-state 'bytes 0) - (endpoint #:subscriber (cons (eof-evt cin) (wild)) - #:state state - [(cons (? evt?) _) - (close-transition state #t)]) - (endpoint #:subscriber (tcp-channel local-addr remote-addr (wild)) - #:state state - #:on-absence (close-transition state #f) - [(tcp-channel (== local-addr) (== remote-addr) subpacket) - (match subpacket - [(? eof-object?) (close-transition state #f)] - [(? bytes? bs) - (define len (bytes-length bs)) - (write-bytes bs cout) - (flush-output cout) - (transition state (send-tcp-credit local-addr remote-addr len))] - [_ - (error 'tcp-connection-manager* - "Publisher on a channel isn't supposed to issue channel control messages")])]) - (endpoint #:publisher (tcp-channel remote-addr local-addr (wild)) - #:state state - #:on-absence (close-transition state #f) - [(tcp-channel (== remote-addr) (== local-addr) subpacket) - (match subpacket - [(tcp-credit amount) - (if state (adjust-credit state amount) (transition state))] - [(tcp-mode new-mode) - ;; Also resets credit to zero. - (if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))] - [_ - (error 'tcp-connection-manager* - "Subscriber on a channel may only send channel control messages")])]))) + (subscribe-to-topic (cons (eof-evt cin) (wild)) + (match-state state + (on-message + [(cons (? evt?) _) + (close-transition state #t)]))) + (subscribe-to-topic (tcp-channel local-addr remote-addr (wild)) + (match-state state + (on-absence (close-transition state #f)) + (on-message + [(tcp-channel (== local-addr) (== remote-addr) subpacket) + (match subpacket + [(? eof-object?) (close-transition state #f)] + [(? bytes? bs) + (define len (bytes-length bs)) + (write-bytes bs cout) + (flush-output cout) + (transition state (send-tcp-credit local-addr remote-addr len))] + [_ + (error 'tcp-connection-manager* + "Publisher on a channel isn't supposed to issue channel control messages")])]))) + (publish-on-topic (tcp-channel remote-addr local-addr (wild)) + (match-state state + (on-absence (close-transition state #f)) + (on-message + [(tcp-channel (== remote-addr) (== local-addr) subpacket) + (match subpacket + [(tcp-credit amount) + (if state (adjust-credit state amount) (transition state))] + [(tcp-mode new-mode) + ;; Also resets credit to zero. + (if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))] + [_ + (error 'tcp-connection-manager* + "Subscriber on a channel may only send channel control messages")])]))))) ;; Spawn ;; Debugging aid: produces pretty hex dumps of TCP traffic sent on @@ -271,8 +278,7 @@ (write `(TCPOTHER ,other)) (newline) (void)])) - (spawn #:debug-name 'tcp-spy - #:child - (transition 'no-state - (endpoint #:subscriber (wild) #:observer [m (display-message m)]) - (endpoint #:publisher (wild) #:observer [m (display-message m)])))) + (name-process 'tcp-spy + (spawn (transition 'no-state + (observe-publishers (wild) (on-message [m (display-message m)])) + (observe-subscribers (wild) (on-message [m (display-message m)])))))) diff --git a/marketplace/drivers/timer.rkt b/marketplace/drivers/timer.rkt index e796567..6ba5ca4 100644 --- a/marketplace/drivers/timer.rkt +++ b/marketplace/drivers/timer.rkt @@ -148,18 +148,18 @@ ;; events and back. (: timer-driver : (All (ParentState) -> (Spawn ParentState))) (define (timer-driver) - (spawn: #:debug-name 'timer-driver - #:parent : ParentState - #:child : DriverState - (transition: (driver-state (make-timer-heap)) : DriverState - (endpoint: state : DriverState - #:subscriber (set-timer-pattern (wild) (wild) (wild)) - [(set-timer label msecs 'relative) - (install-timer! state label (+ (current-inexact-milliseconds) msecs))] - [(set-timer label msecs 'absolute) - (install-timer! state label msecs)]) - (endpoint: : DriverState - #:publisher (timer-expired-pattern (wild) (wild)))))) + (name-process 'timer-driver + (spawn: #:parent : ParentState + #:child : DriverState + (transition: (driver-state (make-timer-heap)) : DriverState + (subscribe-to-topic: 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)]))) + (publish-on-topic: DriverState (timer-expired-pattern (wild) (wild))))))) (: install-timer! : DriverState TimerLabel Real -> (Transition DriverState)) (define (install-timer! state label deadline) @@ -172,42 +172,44 @@ (transition: state : DriverState (delete-endpoint 'time-listener) (and next - (endpoint: state : DriverState - #:subscriber (cons (timer-evt (pending-timer-deadline next)) (wild)) - #:name 'time-listener - [(cons (? evt?) (? real? now)) - (let ((to-send (fire-timers! (driver-state-heap state) now))) - ;; Note: compute to-send before recursing, because of side-effects on heap - (sequence-actions (transition: state : DriverState) - update-time-listener! - to-send))])))) + (name-endpoint 'time-listener + (subscribe-to-topic: DriverState (cons (timer-evt (pending-timer-deadline next)) (wild)) + (match-state state + (on-message + [(cons (? evt?) (? real? now)) + (let ((to-send (fire-timers! (driver-state-heap state) now))) + ;; Note: compute to-send before recursing, because of side-effects on heap + (sequence-actions (transition: state : DriverState) + update-time-listener! + to-send))]))))))) ;; Process for mapping this-level timer requests to meta-level timer ;; requests. Useful when running nested VMs: essentially extends timer ;; support up the branches of the VM tree toward the leaves. (: timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))) (define (timer-relay self-id) - (spawn: #:debug-name `(timer-relay ,self-id) - #:parent : ParentState - #:child : RelayState - (transition: (relay-state 0 (make-immutable-hash '())) : RelayState - (at-meta-level - (endpoint: (relay-state next-counter active-timers) : RelayState - #:subscriber (timer-expired-pattern (wild) (wild)) - [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter)) - now) - (transition: (relay-state next-counter (hash-remove active-timers counter)) - : RelayState - (and (hash-has-key? active-timers counter) - (send-message (timer-expired (hash-ref active-timers counter) - now))))])) - (endpoint: (relay-state next-counter active-timers) : RelayState - #:subscriber (set-timer-pattern (wild) (wild) (wild)) - [(set-timer label msecs kind) - (transition: (relay-state (+ next-counter 1) - (hash-set active-timers next-counter label)) - : RelayState - (at-meta-level: : RelayState - (send-message (set-timer (list self-id next-counter) msecs kind))))]) - (endpoint: : RelayState - #:publisher (timer-expired-pattern (wild) (wild)))))) + (name-process `(timer-relay ,self-id) + (spawn: #:parent : ParentState + #:child : RelayState + (transition: (relay-state 0 (make-immutable-hash '())) : RelayState + (at-meta-level: RelayState + (subscribe-to-topic: 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))))])))) + (subscribe-to-topic: RelayState (set-timer-pattern (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)) + : RelayState + (at-meta-level: RelayState + (send-message (set-timer (list self-id next-counter) msecs kind))))]))) + (publish-on-topic: RelayState (timer-expired-pattern (wild) (wild))))))) diff --git a/marketplace/drivers/udp.rkt b/marketplace/drivers/udp.rkt index ec9beb6..7d0df38 100644 --- a/marketplace/drivers/udp.rkt +++ b/marketplace/drivers/udp.rkt @@ -133,41 +133,38 @@ (transition: (set-add active-handles local-addr) : DriverState (udp-socket-manager local-addr))])) - (spawn: #:debug-name 'udp-driver - #:parent : ParentState - #:child : DriverState - (transition: ((inst set UdpLocalAddress)) : DriverState - (endpoint: active-handles : DriverState - #:publisher - (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) - #:observer - #:conversation topic - #:on-presence (handle-presence topic active-handles)) - (endpoint: active-handles : DriverState - #:publisher - (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild)) - #:observer - #:conversation topic - #:on-presence (handle-presence topic active-handles)) - (endpoint: active-handles : DriverState - #:subscriber - (udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) - #:observer - #:conversation topic - #:on-presence (handle-presence topic active-handles)) - (endpoint: active-handles : DriverState - #:subscriber - (udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild)) - #:observer - #:conversation topic - #:on-presence (handle-presence topic active-handles)) - (endpoint: active-handles : DriverState - #:subscriber (handle-mapping-pattern (wild) (wild)) - #:observer - #:conversation (handle-mapping local-addr socket) - #:on-absence - (transition: (set-remove active-handles local-addr) : DriverState)) - ))) + (name-process 'udp-driver + (spawn: #:parent : ParentState + #:child : DriverState + (transition: ((inst set UdpLocalAddress)) : DriverState + + (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-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))))) + )))) (: bind-socket! : UDP-Socket UdpLocalAddress -> Void) (define (bind-socket! s local-addr) @@ -192,43 +189,46 @@ (transition: #f : SocketManagerState (quit) (when socket-is-open? - (spawn: #:debug-name `(udp-socket-closer ,local-addr) - #:parent : SocketManagerState - #:child : Void - (begin (udp-close s) - (transition: (void) : Void (quit))))))) + (name-process `(udp-socket-closer ,local-addr) + (spawn: #:parent : SocketManagerState + #:child : Void + (begin (udp-close s) + (transition: (void) : Void (quit)))))))) - (spawn: #:debug-name `(udp-socket-manager ,local-addr) - #:parent : DriverState - #:child : SocketManagerState - (transition: #t : SocketManagerState - ;; Offers a handle-mapping on the local network so that - ;; the driver/factory can clean up when this process dies. - (endpoint: : SocketManagerState #:publisher (handle-mapping local-addr s)) - ;; If our counterparty removes either of their endpoints - ;; as the subscriber end of the remote-to-local stream or - ;; the publisher end of the local-to-remote stream, shut - ;; ourselves down. Also, relay messages published on the - ;; local-to-remote stream out on the actual socket. - (endpoint: socket-is-open? : SocketManagerState - #:publisher (udp-packet-pattern any-remote local-addr (wild)) - #:on-absence (handle-absence socket-is-open?)) - (endpoint: socket-is-open? : SocketManagerState - #:subscriber (udp-packet-pattern local-addr any-remote (wild)) - #:on-absence (handle-absence socket-is-open?) - [(udp-packet (== local-addr) - (udp-remote-address remote-host remote-port) - body) - (begin (udp-send-to s remote-host remote-port body) - (transition: socket-is-open? : SocketManagerState))]) - ;; Listen for messages arriving on the actual socket using - ;; a ground event, and relay them at this level. - (endpoint: : SocketManagerState - #:subscriber (cons (udp-receive!-evt s buffer) (wild)) - [(cons (? evt?) (list (? exact-integer? packet-length) - (? string? remote-host) - (? valid-port-number? remote-port))) - (let ((packet (subbytes buffer 0 packet-length))) - (send-message (udp-packet (udp-remote-address remote-host remote-port) - local-addr - packet)))])))) + (name-process `(udp-socket-manager ,local-addr) + (spawn: #:parent : DriverState + #:child : SocketManagerState + (transition: #t : SocketManagerState + ;; Offers a handle-mapping on the local network so that + ;; the driver/factory can clean up when this process dies. + (publish-on-topic: SocketManagerState (handle-mapping local-addr s)) + ;; If our counterparty removes either of their endpoints + ;; as the subscriber end of the remote-to-local stream or + ;; the publisher end of the local-to-remote stream, shut + ;; ourselves down. Also, relay messages published on the + ;; local-to-remote stream out on the actual socket. + (publish-on-topic: SocketManagerState + (udp-packet-pattern any-remote local-addr (wild)) + (match-state socket-is-open? + (on-absence (handle-absence socket-is-open?)))) + (subscribe-to-topic: SocketManagerState + (udp-packet-pattern local-addr any-remote (wild)) + (match-state socket-is-open? + (on-absence (handle-absence socket-is-open?)) + (on-message + [(udp-packet (== local-addr) + (udp-remote-address remote-host remote-port) + body) + (begin (udp-send-to s remote-host remote-port body) + (transition: socket-is-open? : SocketManagerState))]))) + ;; Listen for messages arriving on the actual socket using + ;; a ground event, and relay them at this level. + (subscribe-to-topic: SocketManagerState (cons (udp-receive!-evt s buffer) (wild)) + (on-message + [(cons (? evt?) (list (? exact-integer? packet-length) + (? string? remote-host) + (? valid-port-number? remote-port))) + (let ((packet (subbytes buffer 0 packet-length))) + (send-message (udp-packet (udp-remote-address remote-host remote-port) + local-addr + packet)))])))))) diff --git a/marketplace/examples/chat-client.rkt b/marketplace/examples/chat-client.rkt index c027e63..be647ae 100644 --- a/marketplace/examples/chat-client.rkt +++ b/marketplace/examples/chat-client.rkt @@ -4,44 +4,43 @@ ;; Usually it's OK to just use display and friends directly. ;; Here we have a console output driver just to show how it's done. -(spawn #:debug-name 'console-output-driver - #:child - (transition/no-state - (endpoint #:subscriber (list 'console-output ?) - [(list 'console-output item) - (begin (printf "~a" item) - (void))]))) +(name-process 'console-output-driver + (spawn (transition/no-state + (subscribe-to-topic (list 'console-output ?) + (on-message [(list 'console-output item) + (printf "~a" item) + (void)]))))) -(spawn #:debug-name 'console-input-driver - #:child - (transition/no-state - (endpoint #:publisher (list 'console-input ?) - #:name 'input-relay - #:on-absence - (list (send-message (list 'console-output "Connection terminated.\n")) - (quit))) - (endpoint #:subscriber (cons (read-line-evt (current-input-port) 'any) ?) - [(cons _ (? eof-object?)) - (list (send-message (list 'console-output "Terminating on local EOF.\n")) - (delete-endpoint 'input-relay))] - [(cons _ (? string? line)) - (send-message (list 'console-input line))]))) +(name-process 'console-input-driver + (spawn (transition/no-state + (name-endpoint 'input-relay + (publish-on-topic (list 'console-input ?) + (on-absence + (send-message (list 'console-output "Connection terminated.\n")) + (quit)))) + (subscribe-to-topic (cons (read-line-evt (current-input-port) 'any) ?) + (on-message + [(cons _ (? eof-object?)) + (send-message (list 'console-output "Terminating on local EOF.\n")) + (delete-endpoint 'input-relay)] + [(cons _ (? string? line)) + (send-message (list 'console-input line))]))))) -(spawn #:debug-name 'outbound-connection - #:child - (let ((local (tcp-handle 'outbound)) - (remote (tcp-address "localhost" 5999))) - (transition/no-state - (endpoint #:subscriber (list 'console-input ?) - #:on-absence (quit) - [(list 'console-input line) - (list (send-message (list 'console-output (format "> ~a \n" line))) - (send-message (tcp-channel local remote (string-append line "\n"))))]) - (endpoint #:publisher (tcp-channel local remote ?)) - (endpoint #:subscriber (tcp-channel remote local ?) - #:on-absence (quit) - [(tcp-channel _ _ (? eof-object?)) - (quit)] - [(tcp-channel _ _ data) - (list (send-message (list 'console-output (format "< ~a" data))) - (void))])))) +(name-process 'outbound-connection + (spawn (let ((local (tcp-handle 'outbound)) + (remote (tcp-address "localhost" 5999))) + (transition/no-state + (subscribe-to-topic (list 'console-input ?) + (on-absence (quit)) + (on-message + [(list 'console-input line) + (send-message (list 'console-output (format "> ~a \n" line))) + (send-message (tcp-channel local remote (string-append line "\n")))])) + (publish-on-topic (tcp-channel local remote ?)) + (subscribe-to-topic (tcp-channel remote local ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ (? eof-object?)) + (quit)] + [(tcp-channel _ _ data) + (send-message (list 'console-output (format "< ~a" data)))])))))) diff --git a/marketplace/examples/chat-paper-extrasugar.rkt b/marketplace/examples/chat-paper-extrasugar.rkt deleted file mode 100644 index de73c4e..0000000 --- a/marketplace/examples/chat-paper-extrasugar.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang marketplace -(require "../extrasugar.rkt") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(nested-vm - (at-meta-level - (observe-publishers (tcp-channel ? (tcp-listener 5999) ?) - (match-conversation (tcp-channel them us _) - (on-presence (spawn #:child (chat-session them us))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (chat-session them us) - (define user (gensym 'user)) - (transition stateless - (listen-to-user user them us) - (speak-to-user user them us))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (listen-to-user user them us) - (list - (publish-on-topic `(,user says ,?)) - (at-meta-level - (subscribe-to-topic (tcp-channel them us ?) - (on-absence (quit)) - (on-message - [(tcp-channel _ _ (? bytes? text)) - (send-message `(,user says ,text))]))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (speak-to-user user them us) - (define (say fmt . args) - (at-meta-level - (send-message - (tcp-channel us them (apply format fmt args))))) - (define (announce who did-what) - (unless (equal? who user) - (say "~s ~s.~n" who did-what))) - (list - (say "You are ~s.~n" user) - (at-meta-level - (publish-on-topic (tcp-channel us them ?))) - (subscribe-to-topic `(,? says ,?) - (match-conversation `(,who says ,_) - (on-presence (announce who 'arrived)) - (on-absence (announce who 'departed)) - (on-message [`(,who says ,what) - (say "~a: ~a" who what)]))))) diff --git a/marketplace/examples/chat-paper.rkt b/marketplace/examples/chat-paper.rkt index 9518aad..5e18125 100644 --- a/marketplace/examples/chat-paper.rkt +++ b/marketplace/examples/chat-paper.rkt @@ -1,29 +1,31 @@ #lang marketplace +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (nested-vm (at-meta-level - (endpoint - #:subscriber (tcp-channel ? (tcp-listener 5999) ?) - #:observer - #:conversation (tcp-channel them us _) - #:on-presence - (spawn #:child (chat-session them us))))) + (observe-publishers (tcp-channel ? (tcp-listener 5999) ?) + (match-conversation (tcp-channel them us _) + (on-presence (spawn (chat-session them us))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (chat-session them us) (define user (gensym 'user)) (transition stateless (listen-to-user user them us) (speak-to-user user them us))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (listen-to-user user them us) (list - (endpoint #:publisher `(,user says ,?)) + (publish-on-topic `(,user says ,?)) (at-meta-level - (endpoint #:subscriber (tcp-channel them us ?) - #:on-absence (quit) - [(tcp-channel _ _ (? bytes? text)) - (send-message `(,user says ,text))])))) + (subscribe-to-topic (tcp-channel them us ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ (? bytes? text)) + (send-message `(,user says ,text))]))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (speak-to-user user them us) (define (say fmt . args) (at-meta-level @@ -35,9 +37,10 @@ (list (say "You are ~s.~n" user) (at-meta-level - (endpoint #:publisher (tcp-channel us them ?))) - (endpoint #:subscriber `(,? says ,?) - #:conversation `(,who says ,_) - #:on-presence (announce who 'arrived) - #:on-absence (announce who 'departed) - [`(,who says ,what) (say "~a: ~a" who what)]))) + (publish-on-topic (tcp-channel us them ?))) + (subscribe-to-topic `(,? says ,?) + (match-conversation `(,who says ,_) + (on-presence (announce who 'arrived)) + (on-absence (announce who 'departed)) + (on-message [`(,who says ,what) + (say "~a: ~a" who what)]))))) diff --git a/marketplace/examples/debug-chat.rkt b/marketplace/examples/debug-chat.rkt index 100b925..642c3ff 100644 --- a/marketplace/examples/debug-chat.rkt +++ b/marketplace/examples/debug-chat.rkt @@ -4,16 +4,12 @@ (debug (nested-vm - #:debug-name 'echo (at-meta-level - (endpoint - #:subscriber (tcp-channel ? (tcp-listener 5999) ?) - #:observer - #:conversation (tcp-channel them us _) - #:on-presence - (debug - (spawn #:debug-name (list 'session them) - #:child (chat-session them us))))))) + (observe-publishers (tcp-channel ? (tcp-listener 5999) ?) + (match-conversation (tcp-channel them us _) + (on-presence + (debug (name-process (list 'session them) + (spawn (chat-session them us)))))))))) (define (chat-session them us) (define user (gensym 'user)) @@ -23,12 +19,13 @@ (define (listen-to-user user them us) (list - (endpoint #:publisher `(,user says ,?)) + (publish-on-topic `(,user says ,?)) (at-meta-level - (endpoint #:subscriber (tcp-channel them us ?) - #:on-absence (quit) - [(tcp-channel _ _ (? bytes? text)) - (send-message `(,user says ,text))])))) + (subscribe-to-topic (tcp-channel them us ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ (? bytes? text)) + (send-message `(,user says ,text))]))))) (define (speak-to-user user them us) (define (say fmt . args) @@ -41,9 +38,10 @@ (list (say "You are ~s.~n" user) (at-meta-level - (endpoint #:publisher (tcp-channel us them ?))) - (endpoint #:subscriber `(,? says ,?) - #:conversation `(,who says ,_) - #:on-presence (announce who 'arrived) - #:on-absence (announce who 'departed) - [`(,who says ,what) (say "~a: ~a" who what)]))) + (publish-on-topic (tcp-channel us them ?))) + (subscribe-to-topic `(,? says ,?) + (match-conversation `(,who says ,_) + (on-presence (announce who 'arrived)) + (on-absence (announce who 'departed)) + (on-message [`(,who says ,what) + (say "~a: ~a" who what)]))))) diff --git a/marketplace/examples/echo-paper.rkt b/marketplace/examples/echo-paper.rkt index 964d85d..a0f5974 100644 --- a/marketplace/examples/echo-paper.rkt +++ b/marketplace/examples/echo-paper.rkt @@ -1,14 +1,13 @@ #lang marketplace -(endpoint - #:subscriber (tcp-channel ? (tcp-listener 5999) ?) - #:conversation (tcp-channel from to _) - #:on-presence (spawn #:child (echoer from to))) +(subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?) + (match-conversation (tcp-channel from to _) + (on-presence (spawn (echoer from to))))) (define (echoer from to) (transition stateless - (endpoint - #:subscriber (tcp-channel from to ?) - #:on-absence (quit) - [(tcp-channel _ _ data) - (send-message (tcp-channel to from data))]))) + (subscribe-to-topic (tcp-channel from to ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ data) + (send-message (tcp-channel to from data))])))) diff --git a/marketplace/examples/echo-plain.rkt b/marketplace/examples/echo-plain.rkt index 4100341..c596191 100644 --- a/marketplace/examples/echo-plain.rkt +++ b/marketplace/examples/echo-plain.rkt @@ -6,13 +6,13 @@ (define (echoer from to) (transition/no-state - (endpoint - #:subscriber (tcp-channel from to ?) - #:on-absence (quit) - [(tcp-channel _ _ data) - (send-message (tcp-channel to from data))]))) + (subscribe-to-topic (tcp-channel from to ?) + (on-absence (quit)) + (on-message + [(tcp-channel _ _ data) + (send-message (tcp-channel to from data))])))) (ground-vm tcp - (endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?) - #:conversation (tcp-channel from to _) - #:on-presence (spawn #:child (echoer from to)))) + (subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?) + (match-conversation (tcp-channel from to _) + (on-presence (spawn (echoer from to)))))) diff --git a/marketplace/sugar-endpoints-typed.rkt b/marketplace/sugar-endpoints-typed.rkt new file mode 100644 index 0000000..370baa9 --- /dev/null +++ b/marketplace/sugar-endpoints-typed.rkt @@ -0,0 +1,257 @@ +#lang typed/racket/base + +(require (for-syntax syntax/parse)) +(require (for-syntax racket/base)) +(require "support/dsl-typed.rkt") +(require (for-syntax "support/dsl-typed.rkt")) + +(require racket/match) + +(require (prefix-in core: "main.rkt")) + +(provide name-endpoint + let-fresh + observe-subscribers: + observe-subscribers/everything: + observe-publishers: + observe-publishers/everything: + publish-on-topic: + subscribe-to-topic: + build-endpoint:) + +(define&provide-dsl-helper-syntaxes "endpoint definition context" + [match-state + match-orientation + match-conversation + match-interest-type + match-reason + on-presence + on-absence + on-message]) + +;; Must handle: +;; - orientation +;; - interest-type +;; - let-name +;; - naming of endpoints +;; - state matching +;; - conversation (and generally role) matching +;; - presence event handling +;; - absence event handling (including reason matching) +;; - message event handling (including message matching) + +(: name-endpoint : (All (State) Any (core:AddEndpoint State) -> (core:AddEndpoint State))) +(define (name-endpoint n e) + (match e + [(core:add-endpoint _ role handler) + (core:add-endpoint (cast n core:PreEID) role handler)])) + +(define-syntax-rule (let-fresh (id ...) exp ...) + (let ((id (gensym 'id)) ...) exp ...)) + +(define-syntax-rule (observe-subscribers: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'publisher (cast topic core:Topic) 'observer) + clause ...)) + +(define-syntax-rule (observe-subscribers/everything: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'publisher (cast topic core:Topic) 'everything) + clause ...)) + +(define-syntax-rule (observe-publishers: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'subscriber (cast topic core:Topic) 'observer) + clause ...)) + +(define-syntax-rule (observe-publishers/everything: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'subscriber (cast topic core:Topic) 'everything) + clause ...)) + +(define-syntax-rule (publish-on-topic: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'publisher (cast topic core:Topic) 'participant) + clause ...)) + +(define-syntax-rule (subscribe-to-topic: State topic clause ...) + (build-endpoint: State + (gensym 'anonymous-endpoint) + (core:role 'subscriber (cast topic core:Topic) 'participant) + clause ...)) + +(define-syntax build-endpoint: + (lambda (stx) + (define (combine-handler-clauses State + clauses-stx + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx) + + (define (do-tail new-clauses-stx) + (combine-handler-clauses State + new-clauses-stx + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx)) + + (define (stateful-lift context exprs-stx) + (if stateful? + (syntax-case exprs-stx () + [(expr) + #`(lambda: ([state : #,State]) (match state [#,state-stx expr]))] + [_ + (raise-syntax-error #f + (format "Expected exactly one expression resulting in a transition, in ~a handler" + context) + stx + exprs-stx)]) + (syntax-case exprs-stx () + [(expr ...) + #`(lambda: ([state : #,State]) (core:transition state (list expr ...)))]))) + + (syntax-case clauses-stx () + [() '()] + + [((maybe-match-state pat-stx inner-clause ...) outer-clause ...) + (literal-identifier=? #'maybe-match-state #'match-state) + (append (combine-handler-clauses State + (syntax (inner-clause ...)) + #t + #'pat-stx + orientation-stx + conversation-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((maybe-match-orientation pat-stx inner-clause ...) outer-clause ...) + (literal-identifier=? #'maybe-match-orientation #'match-orientation) + (append (combine-handler-clauses State + (syntax (inner-clause ...)) + stateful? + state-stx + #'pat-stx + conversation-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((maybe-match-conversation pat-stx inner-clause ...) outer-clause ...) + (literal-identifier=? #'maybe-match-conversation #'match-conversation) + (append (combine-handler-clauses State + (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + #'pat-stx + interest-type-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((maybe-match-interest-type pat-stx inner-clause ...) outer-clause ...) + (literal-identifier=? #'maybe-match-interest-type #'match-interest-type) + (append (combine-handler-clauses State + (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + conversation-stx + #'pat-stx + reason-stx) + (do-tail (syntax (outer-clause ...))))] + + [((maybe-match-reason pat-stx inner-clause ...) outer-clause ...) + (literal-identifier=? #'maybe-match-reason #'match-reason) + (append (combine-handler-clauses State + (syntax (inner-clause ...)) + stateful? + state-stx + orientation-stx + conversation-stx + interest-type-stx + #'pat-stx) + (do-tail (syntax (outer-clause ...))))] + + [((maybe-on-presence expr ...) outer-clause ...) + (literal-identifier=? #'maybe-on-presence #'on-presence) + (cons #`[(core:presence-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx)) + #,(stateful-lift 'on-presence (syntax (expr ...)))] + (do-tail (syntax (outer-clause ...))))] + + [((maybe-on-absence expr ...) outer-clause ...) + (literal-identifier=? #'maybe-on-absence #'on-absence) + (cons #`[(core:absence-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx) + #,reason-stx) + #,(stateful-lift 'on-absence (syntax (expr ...)))] + (do-tail (syntax (outer-clause ...))))] + + [((maybe-on-message [message-pat expr ...] ...) outer-clause ...) + (literal-identifier=? #'maybe-on-message #'on-message) + (cons #`[(core:message-event (core:role #,orientation-stx + #,conversation-stx + #,interest-type-stx) + message) + (match message + #,@(map (lambda (message-clause) + (syntax-case message-clause () + ([message-pat expr ...] + #`[message-pat #,(stateful-lift 'on-message + (syntax (expr ...)))]))) + (syntax->list (syntax ([message-pat expr ...] ...)))) + [_ (lambda: ([state : #,State]) (core:transition state '()))])] + (do-tail (syntax (outer-clause ...))))] + + [(unknown-clause outer-clause ...) + (raise-syntax-error #f + "Illegal clause in endpoint definition" + stx + #'unknown-clause)])) + + (syntax-case stx () + [(dummy State pre-eid-exp role-exp handler-clause ...) + #`(core:add-endpoint (cast pre-eid-exp core:PreEID) + role-exp + (match-lambda + #,@(reverse + (combine-handler-clauses + #'State + (syntax (handler-clause ...)) + #f + (syntax old-state) + (syntax _) + (syntax _) + (syntax _) + (syntax _))) + [_ (lambda: ([state : State]) (core:transition state '()))]))]))) + +;;; Local Variables: +;;; eval: (put 'name-endpoint 'scheme-indent-function 1) +;;; eval: (put 'let-fresh 'scheme-indent-function 1) +;;; eval: (put 'observe-subscribers: 'scheme-indent-function 2) +;;; eval: (put 'observe-subscribers/everything: 'scheme-indent-function 2) +;;; eval: (put 'observe-publishers: 'scheme-indent-function 2) +;;; eval: (put 'observe-publishers/everything: 'scheme-indent-function 2) +;;; eval: (put 'publish-on-topic: 'scheme-indent-function 2) +;;; eval: (put 'subscribe-to-topic: 'scheme-indent-function 2) +;;; eval: (put 'match-state 'scheme-indent-function 1) +;;; eval: (put 'match-orientation 'scheme-indent-function 1) +;;; eval: (put 'match-conversation 'scheme-indent-function 1) +;;; eval: (put 'match-interest-type 'scheme-indent-function 1) +;;; eval: (put 'match-reason 'scheme-indent-function 1) +;;; End: diff --git a/marketplace/extrasugar.rkt b/marketplace/sugar-endpoints-untyped.rkt similarity index 67% rename from marketplace/extrasugar.rkt rename to marketplace/sugar-endpoints-untyped.rkt index f54df90..6f584b0 100644 --- a/marketplace/extrasugar.rkt +++ b/marketplace/sugar-endpoints-untyped.rkt @@ -2,52 +2,31 @@ (require (for-syntax syntax/parse)) (require (for-syntax racket/base)) - -(require racket/stxparam) -(require racket/splicing) +(require "support/dsl-untyped.rkt") (require racket/match) (require (prefix-in core: "main.rkt")) -(require (except-in "main.rkt" - at-meta-level - spawn - yield - transition - delete-endpoint - send-message - quit)) -(require "sugar-untyped.rkt") -(provide (except-out (all-from-out "sugar-untyped.rkt") endpoint) - (all-from-out "main.rkt") - name-endpoint +(provide name-endpoint let-fresh observe-subscribers + observe-subscribers/everything observe-publishers + observe-publishers/everything publish-on-topic subscribe-to-topic build-endpoint) -(define-syntax-rule (define&provide-endpoint-helper-syntaxes identifier ...) - (begin (provide identifier ...) - (define-syntax identifier - (lambda (stx) - (raise-syntax-error #f - (format "Illegal use of ~a outside endpoint definition context" - 'identifier) - stx))) - ...)) - -(define&provide-endpoint-helper-syntaxes - match-state - match-orientation - match-conversation - match-interest-type - match-reason - on-presence - on-absence - on-message) +(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 @@ -73,11 +52,21 @@ (core:role 'publisher topic 'observer) clause ...)) +(define-syntax-rule (observe-subscribers/everything topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'publisher topic 'everything) + clause ...)) + (define-syntax-rule (observe-publishers topic clause ...) (build-endpoint (gensym 'anonymous-endpoint) (core:role 'subscriber topic 'observer) clause ...)) +(define-syntax-rule (observe-publishers/everything topic clause ...) + (build-endpoint (gensym 'anonymous-endpoint) + (core:role 'subscriber topic 'everything) + clause ...)) + (define-syntax-rule (publish-on-topic topic clause ...) (build-endpoint (gensym 'anonymous-endpoint) (core:role 'publisher topic 'participant) @@ -107,10 +96,20 @@ interest-type-stx reason-stx)) - (define (stateful-lift expr-stx) + (define (stateful-lift context exprs-stx) (if stateful? - #`(match-lambda [#,state-stx #,expr-stx]) - #`(lambda (state) (core:transition state #,expr-stx)))) + (syntax-case exprs-stx () + [(expr) + #`(match-lambda [#,state-stx expr])] + [_ + (raise-syntax-error #f + (format "Expected exactly one expression resulting in a transition, in ~a handler" + context) + stx + exprs-stx)]) + (syntax-case exprs-stx () + [(expr ...) + #`(lambda (state) (core:transition state (list expr ...)))]))) (syntax-case clauses-stx (match-state match-orientation @@ -176,7 +175,7 @@ (cons #`[(core:presence-event (core:role #,orientation-stx #,conversation-stx #,interest-type-stx)) - #,(stateful-lift (syntax (begin expr ...)))] + #,(stateful-lift 'on-presence (syntax (expr ...)))] (do-tail (syntax (outer-clause ...))))] [((on-absence expr ...) outer-clause ...) @@ -184,7 +183,7 @@ #,conversation-stx #,interest-type-stx) #,reason-stx) - #,(stateful-lift (syntax (begin expr ...)))] + #,(stateful-lift 'on-absence (syntax (expr ...)))] (do-tail (syntax (outer-clause ...))))] [((on-message [message-pat expr ...] ...) outer-clause ...) @@ -196,10 +195,17 @@ #,@(map (lambda (message-clause) (syntax-case message-clause () ([message-pat expr ...] - #`[message-pat #,(stateful-lift (syntax (begin expr ...)))]))) + #`[message-pat #,(stateful-lift 'on-message + (syntax (expr ...)))]))) (syntax->list (syntax ([message-pat expr ...] ...)))) [_ (lambda (state) (core:transition state '()))])] - (do-tail (syntax (outer-clause ...))))])) + (do-tail (syntax (outer-clause ...))))] + + [(unknown-clause outer-clause ...) + (raise-syntax-error #f + "Illegal clause in endpoint definition" + stx + #'unknown-clause)])) (syntax-case stx () [(dummy pre-eid-exp role-exp handler-clause ...) @@ -216,3 +222,19 @@ (syntax _) (syntax _))) [_ (lambda (state) (core:transition state '()))]))]))) + +;;; Local Variables: +;;; eval: (put 'name-endpoint 'scheme-indent-function 1) +;;; eval: (put 'let-fresh 'scheme-indent-function 1) +;;; eval: (put 'observe-subscribers 'scheme-indent-function 1) +;;; eval: (put 'observe-subscribers/everything 'scheme-indent-function 1) +;;; eval: (put 'observe-publishers 'scheme-indent-function 1) +;;; eval: (put 'observe-publishers/everything 'scheme-indent-function 1) +;;; eval: (put 'publish-on-topic 'scheme-indent-function 1) +;;; eval: (put 'subscribe-to-topic 'scheme-indent-function 1) +;;; eval: (put 'match-state 'scheme-indent-function 1) +;;; eval: (put 'match-orientation 'scheme-indent-function 1) +;;; eval: (put 'match-conversation 'scheme-indent-function 1) +;;; eval: (put 'match-interest-type 'scheme-indent-function 1) +;;; eval: (put 'match-reason 'scheme-indent-function 1) +;;; End: diff --git a/marketplace/sugar-typed.rkt b/marketplace/sugar-typed.rkt index 1ca3200..694a04d 100644 --- a/marketplace/sugar-typed.rkt +++ b/marketplace/sugar-typed.rkt @@ -15,14 +15,17 @@ quit wild)) (require "sugar-values.rkt") +(require "sugar-endpoints-typed.rkt") (provide (all-from-out "sugar-values.rkt") + (all-from-out "sugar-endpoints-typed.rkt") (all-from-out "main.rkt") ? transition: transition/no-state - endpoint: spawn: + spawn/continue: + name-process yield: at-meta-level: nested-vm: @@ -40,132 +43,50 @@ (define-syntax-rule (transition/no-state action ...) (transition: (void) : Void action ...)) -(define-syntax endpoint: - (lambda (stx) - (syntax-parse stx - [(_ (~or (~seq (~literal :) State) - (~seq state-pattern (~literal :) State)) - (~or (~seq #:subscriber (~bind [is-subscriber #'#t])) - (~seq #:publisher (~bind [is-publisher #'#t]))) - topic-expr - (~or (~seq #:participant (~bind [is-participant #'#t])) - (~seq #:observer (~bind [is-observer #'#t])) - (~seq #:everything (~bind [is-everything #'#t])) - (~seq)) - (~or (~optional (~seq #:let-name name-binding) - #:defaults ([name-binding #'n0]) - #:name "#:let-name binding for endpoint name") - (~optional (~seq #:name pre-eid) #:name "#:name of endpoint") - (~optional (~seq #:on-presence presence) #:name "#:on-presence handler") - (~optional (~seq #:on-absence absence) #:name "#:on-absence handler") - - (~optional (~seq #:role role) #:name "#:role") - (~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation") - (~optional (~seq #:conversation conversation) #:name "#:conversation") - (~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type") - - (~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason")) - ... - [message-pattern clause-body] - ...) - (define-syntax-rule (build-handler event-pattern e-attr) - (if (attribute e-attr) - #`([event-pattern - #,(if (attribute state-pattern) - #`(lambda: ([state : State]) (match state [state-pattern e-attr])) - #`(lambda: ([state : State]) ((inst core:transition State) state e-attr)))]) - #`([event-pattern (lambda: ([state : State]) - (core:transition state '()))]))) - (define role-pattern - (cond - [(attribute role) - (when (or (attribute orientation) - (attribute conversation) - (attribute interest)) - (raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx)) - #'role] - [else - #`(core:role #,(if (attribute orientation) #'orientation #'_) - #,(if (attribute conversation) #'conversation #'_) - #,(if (attribute interest) #'interest #'_))])) - #`(let ((name-binding (cast #,(if (attribute pre-eid) - #'pre-eid - #'(gensym 'anonymous-endpoint)) - core:PreEID))) - (core:add-endpoint - name-binding - (core:role #,(cond - [(attribute is-subscriber) #''subscriber] - [(attribute is-publisher) #''publisher] - [else (raise-syntax-error #f - "Missing #:subscriber or #:publisher" - stx)]) - (cast topic-expr core:Topic) - #,(cond - [(attribute is-participant) #''participant] - [(attribute is-observer) #''observer] - [(attribute is-everything) #''everything] - [else #''participant])) - (match-lambda - #,@(build-handler (core:presence-event #,role-pattern) presence) - #,@(build-handler (core:absence-event #,role-pattern reason) absence) - [(core:message-event #,role-pattern message) - #,(if (attribute state-pattern) - #`(lambda: ([state : State]) - (match state - [state-pattern - (match message - [message-pattern clause-body] ... - [_ (core:transition state '())])])) - #`(lambda: ([state : State]) - ((inst core:transition State) - state - (match message - [message-pattern clause-body] ... - [_ '()]))))] - [_ - (lambda: ([state : State]) (core:transition state '()))])))]))) - (define-syntax spawn: (lambda (stx) (syntax-parse stx - [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid") - (~optional (~seq #:debug-name debug-name) - #:defaults ([debug-name #'#f]) - #:name "#:debug-name")) ... - (~or (~seq #:parent parent-state-pattern (~literal :) ParentState - (~and (~not #:child) parent-k-exp)) - (~seq #:parent (~literal :) ParentState - (~and (~not #:child) parent-k-exp)) - (~seq #:parent (~literal :) ParentState)) + [(_ (~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)))) - #,(if (attribute parent-k-exp) - (if (attribute parent-state-pattern) - #`(lambda (pid) - (lambda: ([parent-state : 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]))) - #`(lambda (pid) - (lambda: ([parent-state : ParentState]) - ((inst core:transition ParentState) parent-state parent-k-exp)))) - #'#f) - debug-name)]))) + #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])))] - [(_ : State exp) - #'((inst core:yield State) (lambda (state) (core:transition state exp)))]))) + #'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))]))) (define-syntax at-meta-level: (lambda (stx) - (syntax-case stx (:) - [(_ : State preaction ...) - #'((inst at-meta-level State) preaction ...)]))) + (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 nested-vm: (lambda (stx) @@ -208,5 +129,5 @@ (list exp ...)))))))]))) ;;; Local Variables: -;;; eval: (put 'at-meta-level: 'scheme-indent-function 2) +;;; eval: (put 'at-meta-level: 'scheme-indent-function 1) ;;; End: diff --git a/marketplace/sugar-untyped.rkt b/marketplace/sugar-untyped.rkt index cb5165b..a0bd36e 100644 --- a/marketplace/sugar-untyped.rkt +++ b/marketplace/sugar-untyped.rkt @@ -14,14 +14,18 @@ send-message quit)) (require "sugar-values.rkt") +(require "sugar-endpoints-untyped.rkt") (provide (all-from-out "sugar-values.rkt") + (all-from-out "sugar-endpoints-untyped.rkt") (all-from-out "main.rkt") ? transition/no-state - endpoint spawn + spawn/continue + name-process yield + at-meta-level nested-vm ground-vm) @@ -31,117 +35,40 @@ ;; A fresh unification variable, as identifier-syntax. (define-syntax ? (syntax-id-rules () (_ (wild)))) -(define-syntax endpoint - (lambda (stx) - (syntax-parse stx - [(_ (~or (~seq #:subscriber (~bind [is-subscriber #'#t])) - (~seq #:publisher (~bind [is-publisher #'#t]))) - topic-expr - (~or (~seq #:participant (~bind [is-participant #'#t])) - (~seq #:observer (~bind [is-observer #'#t])) - (~seq #:everything (~bind [is-everything #'#t])) - (~seq)) - (~or (~optional (~seq #:let-name name-binding) - #:defaults ([name-binding #'n0]) - #:name "#:let-name binding for endpoint name") - (~optional (~seq #:name pre-eid) #:name "#:name of endpoint") - (~optional (~seq #:state state-pattern) #:name "#:state pattern") - (~optional (~seq #:on-presence presence) #:name "#:on-presence handler") - (~optional (~seq #:on-absence absence) #:name "#:on-absence handler") - - (~optional (~seq #:role role) #:name "#:role") - (~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation") - (~optional (~seq #:conversation conversation) #:name "#:conversation") - (~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type") - - (~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason")) - ... - [message-pattern clause-body] - ...) - (define-syntax-rule (build-handler event-pattern e-attr) - (if (attribute e-attr) - #`([event-pattern - #,(if (attribute state-pattern) - #`(match-lambda [state-pattern e-attr]) - #`(lambda (state) (core:transition state e-attr)))]) - #`([event-pattern (lambda (state) (core:transition state '()))]))) - (define role-pattern - (cond - [(attribute role) - (when (or (attribute orientation) - (attribute conversation) - (attribute interest)) - (raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx)) - #'role] - [else - #`(core:role #,(if (attribute orientation) #'orientation #'_) - #,(if (attribute conversation) #'conversation #'_) - #,(if (attribute interest) #'interest #'_))])) - #`(let ((name-binding #,(if (attribute pre-eid) - #'pre-eid - #'(gensym 'anonymous-endpoint)))) - (core:add-endpoint - name-binding - (core:role #,(cond - [(attribute is-subscriber) #''subscriber] - [(attribute is-publisher) #''publisher] - [else (raise-syntax-error #f - "Missing #:subscriber or #:publisher" - stx)]) - topic-expr - #,(cond - [(attribute is-participant) #''participant] - [(attribute is-observer) #''observer] - [(attribute is-everything) #''everything] - [else #''participant])) - (match-lambda - #,@(build-handler (core:presence-event #,role-pattern) presence) - #,@(build-handler (core:absence-event #,role-pattern reason) absence) - [(core:message-event #,role-pattern message) - #,(if (attribute state-pattern) - #`(match-lambda - [(and state state-pattern) - (match message - [message-pattern clause-body] ... - [_ (core:transition state '())])]) - #`(lambda (state) - (core:transition state - (match message - [message-pattern clause-body] ... - [_ '()]))))] - [_ - (lambda (state) (core:transition state '()))])))]))) - (define-syntax spawn (lambda (stx) (syntax-parse stx - [(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid") - (~optional (~seq #:debug-name debug-name) - #:defaults ([debug-name #'#f]) - #:name "#:debug-name")) ... - (~or (~seq #:parent parent-state-pattern (~and (~not #:child) parent-k-exp)) - (~seq #:parent (~and (~not #:child) parent-k-exp)) - (~seq)) + [(_ (~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)))) - #,(if (attribute parent-k-exp) - (if (attribute parent-state-pattern) - #`(lambda (pid) - (match-lambda [parent-state-pattern parent-k-exp])) - #`(lambda (pid) - (lambda (state) - (core:transition state parent-k-exp)))) - #'#f) - debug-name)]))) + #`(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 state-pattern exp) - #'(core:yield (match-lambda [state-pattern exp]))] - [(_ exp) - #'(core:yield (lambda (state) (core:transition state exp)))]))) + [(_ 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 nested-vm (lambda (stx) @@ -179,3 +106,8 @@ (core:process-spec (lambda (boot-pid) (lambda (k) (k (core:transition initial-state (list exp ...)))))))]))) + +;;; Local Variables: +;;; eval: (put 'name-process 'scheme-indent-function 1) +;;; eval: (put 'yield 'scheme-indent-function 1) +;;; End: diff --git a/marketplace/sugar-values.rkt b/marketplace/sugar-values.rkt index 771df76..d9fc043 100644 --- a/marketplace/sugar-values.rkt +++ b/marketplace/sugar-values.rkt @@ -4,7 +4,6 @@ (require (prefix-in core: "main.rkt")) (provide transition - at-meta-level delete-endpoint send-message send-feedback @@ -16,14 +15,6 @@ (define (transition state . actions) ((inst core:transition State) state actions)) -(: at-meta-level : (All (State) - (core:PreAction State) * - -> (core:ActionTree State))) -(define (at-meta-level . preactions) - (match preactions - [(cons preaction '()) (core:at-meta-level preaction)] - [_ ((inst map (core:Action State) (core:PreAction State)) core:at-meta-level preactions)])) - (define (delete-endpoint #{id : Any} [#{reason : Any} #f]) (core:delete-endpoint (cast id core:PreEID) (cast reason core:Reason))) diff --git a/marketplace/support/dsl-typed.rkt b/marketplace/support/dsl-typed.rkt new file mode 100644 index 0000000..31946cb --- /dev/null +++ b/marketplace/support/dsl-typed.rkt @@ -0,0 +1,26 @@ +#lang typed/racket/base + +(require (for-syntax typed/racket/base)) +(provide define&provide-dsl-helper-syntaxes) +(provide literal-identifier=?) + +(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...)) + (begin (provide identifier ...) + (define-syntax identifier + (lambda (stx) + (raise-syntax-error #f + (format "Illegal use of ~a outside ~a" + 'identifier + context) + stx))) + ...)) + +;; Typed racket wraps literal identifiers during provide. Here we dig +;; through the renamings to see if they're the same thing. Gross! +;; Fragile? +(: literal-identifier=? : Syntax Identifier -> Boolean) +(define (literal-identifier=? actual expected) + (and (identifier? actual) + (identifier-binding actual) + (eq? (syntax-local-value actual) + (syntax-local-value expected)))) diff --git a/marketplace/support/dsl-untyped.rkt b/marketplace/support/dsl-untyped.rkt new file mode 100644 index 0000000..cbd5cca --- /dev/null +++ b/marketplace/support/dsl-untyped.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(require (for-syntax racket/base)) +(provide define&provide-dsl-helper-syntaxes) + +(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...)) + (begin (provide identifier ...) + (define-syntax identifier + (lambda (stx) + (raise-syntax-error #f + (format "Illegal use of ~a outside ~a" + 'identifier + context) + stx))) + ...)) diff --git a/marketplace/support/spy.rkt b/marketplace/support/spy.rkt index 3b0868a..839a955 100644 --- a/marketplace/support/spy.rkt +++ b/marketplace/support/spy.rkt @@ -6,27 +6,27 @@ (: generic-spy : (All (ParentState) Any -> (Spawn ParentState))) (define (generic-spy label) - (spawn: #:debug-name `(generic-spy ,label) - #:parent : ParentState - #:child : Void - (transition: (void) : Void - (endpoint: : Void - #:subscriber (wild) #:observer - #:peer-orientation orientation - #:conversation topic - #:peer-interest-type interest - #:reason reason - #:on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest))) + (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))) + '())) + (on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest))) (newline) (display reason) (newline) (flush-output) - '()) - [p (begin (write `(,label MSG ,p)) - (newline) - (flush-output) - '())])))) + '())) + (on-message + [p (begin (write `(,label MSG ,p)) + (newline) + (flush-output) + '())]))))))))))