#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) transition)
      (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 (topic-subscriber (cons always-evt (wild)))
	       #:name 'waiter
	       #: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 (debug-name 'nested-vm)
				 (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)))))