Update to new syntax (documentation not yet updated and does not build)

This commit is contained in:
Tony Garnock-Jones 2013-06-03 14:57:42 -04:00
parent b1438317aa
commit 1f5b8d8251
19 changed files with 894 additions and 769 deletions

View File

@ -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)))))))))))

View File

@ -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<HandleMapping> -> Transition
(define (maybe-forget-socket r active-handles)
(match r
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
;; Orientation Topic Set<HandleMapping> -> Transition
(define (maybe-forget-socket orientation c active-handles)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(ground? remote-addr) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
@ -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))))))

View File

@ -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<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
(match r
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
[else
(transition (set-add active-handles (cons local-addr remote-addr))
(spawn #:debug-name (cons local-addr remote-addr)
#:child (driver-fun local-addr remote-addr)))])]))
(name-process (cons local-addr remote-addr)
(spawn (driver-fun local-addr remote-addr))))])]))
;; Role Set<HandleMapping> -> Transition
(define (maybe-forget-socket r active-handles)
(match r
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
;; Orientation Topic Set<HandleMapping> -> Transition
(define (maybe-forget-socket orientation c active-handles)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(ground? remote-addr) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
@ -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)]))))))

View File

@ -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)))))))

View File

@ -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)))]))))))

View File

@ -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)))]))))))

View File

@ -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)])))))

View File

@ -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)])))))

View File

@ -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)])))))

View File

@ -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))]))))

View File

@ -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))))))

View File

@ -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:

View File

@ -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:

View File

@ -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:

View File

@ -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:

View File

@ -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)))

View File

@ -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))))

View File

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

View File

@ -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)
'())]))))))))))