syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Support broadcast messages

This commit is contained in:
Tony Garnock-Jones 2016-06-27 14:42:42 -04:00
parent 173a0edb54
commit 707245cfe2
3 changed files with 60 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
racket/syndicate/examples/actor/broadcast-messages.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang syndicate
;; Demonstrate sending a message to multiple receivers.
(require syndicate/actor)
(struct envelope (destination message) #:prefab)
(actor (forever (on (message (envelope 'alice $message))
(log-info "Alice received ~v" message))))
(actor (forever (on (message (envelope 'bob $message))
(log-info "Bob received ~v" message))))
(actor
(log-info "Waiting for Alice and Bob.")
(until (asserted (observe (envelope 'alice _))))
(until (asserted (observe (envelope 'bob _))))
(log-info "Sending a few messages...")
(send! (envelope 'alice "For Alice's eyes only"))
(send! (envelope 'bob "Dear Bob, how are you? Kind regards, etc."))
(send! (envelope ? "Important announcement!"))
(log-info "Sent all the messages."))

8
racket/syndicate/mux.rkt
View File

@ -115,9 +115,13 @@
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc))))
(define (mux-route-message m body)
(if (trie-lookup (mux-routing-table m) body #f) ;; some other stream has declared body
(if (trie-lookup (mux-routing-table m) body #f #:wildcard-union (lambda (a b) (or a b)))
;; some other stream has declared body
'()
(tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty))))
(tset->list (trie-lookup (mux-routing-table m)
(observe body)
datum-tset-empty
#:wildcard-union tset-union))))
(define (mux-interests-of m label)
(hash-ref (mux-interest-table m) label trie-empty))

58
racket/syndicate/pattern.rkt
View File

@ -24,34 +24,36 @@
;; Match a single value against a projection, returning a list of
;; captured values.
(define (match-value/captures v p)
(define captures-rev
(let walk ((v v) (p p) (captures-rev '()))
(match* (v p)
[(_ (capture sub))
(match (walk v sub '())
[#f #f]
['() (cons v captures-rev)]
[_ (error 'match-value/captures "Bindings in capture sub-patterns not supported")])]
[(_ (predicate-match pred? sub)) #:when (pred? v)
(walk v sub captures-rev)]
[(_ (== ?))
captures-rev]
[((cons v1 v2) (cons p1 p2))
(match (walk v1 p1 captures-rev)
[#f #f]
[c (walk v2 p2 c)])]
[((? vector? v) (? vector? p)) #:when (= (vector-length v) (vector-length p))
(for/fold [(c captures-rev)] [(vv (in-vector v)) (pp (in-vector p))]
(walk vv pp c))]
[(_ _) #:when (or (treap? v) (treap? p))
(error 'match-value/captures "Cannot match on treaps at present")]
[((? non-object-struct?) (? non-object-struct?))
#:when (eq? (struct->struct-type v) (struct->struct-type p))
(walk (struct->vector v) (struct->vector p) captures-rev)]
[(_ _) #:when (equal? v p)
captures-rev]
[(_ _)
#f])))
(define (walk v p captures-rev)
(match* (v p)
[(_ (capture sub))
(match (walk v sub '())
[#f #f]
['() (cons v captures-rev)]
[_ (error 'match-value/captures "Bindings in capture sub-patterns not supported")])]
[(_ (predicate-match pred? sub)) #:when (pred? v)
(walk v sub captures-rev)]
[((== ?) _)
captures-rev]
[(_ (== ?))
captures-rev]
[((cons v1 v2) (cons p1 p2))
(match (walk v1 p1 captures-rev)
[#f #f]
[c (walk v2 p2 c)])]
[((? vector? v) (? vector? p)) #:when (= (vector-length v) (vector-length p))
(for/fold [(c captures-rev)] [(vv (in-vector v)) (pp (in-vector p))]
(walk vv pp c))]
[(_ _) #:when (or (treap? v) (treap? p))
(error 'match-value/captures "Cannot match on treaps at present")]
[((? non-object-struct?) (? non-object-struct?))
#:when (eq? (struct->struct-type v) (struct->struct-type p))
(walk (struct->vector v) (struct->vector p) captures-rev)]
[(_ _) #:when (equal? v p)
captures-rev]
[(_ _)
#f]))
(define captures-rev (walk v p '()))
(and captures-rev (reverse captures-rev)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;