Event relaying plus an example program
This commit is contained in:
parent
47468b2b37
commit
3fdd1ae746
|
@ -0,0 +1,28 @@
|
|||
#lang racket/base
|
||||
;; Ground-event relay for os2.
|
||||
|
||||
(provide event-relay)
|
||||
(require "os2.rkt")
|
||||
|
||||
(define event-relay
|
||||
(transition 'no-state
|
||||
(role 'relay-down (topic-publisher (cons (wild) (wild)) #:monitor? #t)
|
||||
#:state state
|
||||
#:topic t
|
||||
#:on-presence (match t
|
||||
[(topic 'subscriber (cons (? evt? e) _) #f)
|
||||
(printf "SUBSCRIBED ~v~n" e) (flush-output)
|
||||
(transition state
|
||||
(at-meta-level
|
||||
(role t (topic-subscriber (cons e (wild)))
|
||||
#:state state
|
||||
[msg
|
||||
(printf "FIRED ~v -> ~v~n" e msg) (flush-output)
|
||||
(transition state
|
||||
(send-message msg))])))]
|
||||
[_ state])
|
||||
#:on-absence (match t
|
||||
[(topic 'subscriber (cons (? evt?) e) #f)
|
||||
(printf "UNSUBSCRIBED ~v~n" e) (flush-output)
|
||||
(transition state
|
||||
(at-meta-level (delete-role t)))]))))
|
|
@ -0,0 +1,45 @@
|
|||
#lang racket/base
|
||||
;; Trivial demonstration of nested os2.rkt virtual machines.
|
||||
|
||||
(require "os2.rkt")
|
||||
(require "os2-event-relay.rkt")
|
||||
|
||||
(define (spy spy-label)
|
||||
(lambda (spy-pid)
|
||||
(define (hs label)
|
||||
(define ((w kind) . args) (write `(,spy-label ,label ,kind ,@args)) (newline) values)
|
||||
(handlers (w 'presence)
|
||||
(w 'absence)
|
||||
(w 'message)))
|
||||
(transition 'spy-state
|
||||
(add-role 's->p (topic-publisher (wild) #:monitor? 'everything)
|
||||
(hs 'subscriber->publisher))
|
||||
(add-role 'p->s (topic-subscriber (wild) #:monitor? 'everything)
|
||||
(hs 'publisher->subscriber)))))
|
||||
|
||||
(define (eventing-process label)
|
||||
(spawn (lambda (self-pid)
|
||||
(transition 'no-state
|
||||
(role 'waiter (topic-subscriber (cons always-evt (wild)))
|
||||
#:state state
|
||||
[msg
|
||||
(write `(event ,label ,msg)) (newline) (flush-output)
|
||||
(transition state
|
||||
(delete-role 'waiter))])))
|
||||
#:debug-name (debug-name label)))
|
||||
|
||||
(ground-vm (lambda (boot-pid)
|
||||
(define event-at-ground? #f)
|
||||
(define install-relay? #t)
|
||||
(transition 'no-state
|
||||
(spawn (spy 'ground-spy))
|
||||
(when event-at-ground? (eventing-process 'ground-level-eventing-process))
|
||||
(spawn (nested-vm (debug-name 'nested-vm)
|
||||
(lambda (boot-pid)
|
||||
(transition 'no-state
|
||||
(spawn (spy 'nested-spy))
|
||||
(when install-relay? (spawn event-relay
|
||||
#:debug-name 'event-relay))
|
||||
(when (not event-at-ground?)
|
||||
(eventing-process 'nested-eventing-process)))))
|
||||
#:debug-name (debug-name 'nested-vm)))))
|
Loading…
Reference in New Issue