#lang racket/base

(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "process.rkt")
(require "actions.rkt")
(require "action-send-message.rkt")
(require "quasiqueue.rkt")

(provide run-ground-vm)

;; run-ground-vm : process-spec -> Void
(define (run-ground-vm boot)
  (let loop ((state (make-vm boot)))
    (match (run-vm state)
      [(transition state actions)
       (define is-blocking?
	 (match (quasiqueue->list (action-tree->quasiqueue actions))
	   ['()
	    ;; no "yield" action -> certainly blocking
	    #t]
	   [(list (yield (== run-vm)))
	    ;; single "yield", with k statically known to be run-vm -> poll
	    #f]
	   [_
	    ;; uh-oh
	    (error 'ground-vm
		   "Cannot process meta-actions ~v because no further metalevel exists"
		   actions)]))
       (define active-events
	 (endpoint-fold extract-ground-event-subscriptions '() state))
       (if (and is-blocking?
		(null? active-events))
	   (begin
	     ;; Not polling, and no events that could wake us from blocking, so quit
	     (marketplace-log 'debug "Ground VM returning normally.")
	     (sleep 0.2) ;; give the log-receivers a chance to drain (!)
	     (void))
	   (let ((interruptk (apply sync
				    (if is-blocking?
					never-evt
					(wrap-evt always-evt (lambda (dummy) values)))
				    active-events)))
	     (loop (interruptk state))))])))

;; extract-ground-event-subscriptions :
;;    (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
(define (extract-ground-event-subscriptions old-p ep acc)
  (define pid (process-pid old-p))
  (match (endpoint-role ep)
    [(role 'subscriber (cons (? evt? evt) _) 'participant)
     ;; evt-handler : Any -> (vm -> vm)
     (define ((evt-handler message) state)
       (let-values (((state wp) (extract-process state pid)))
	 (if (not wp)
	     state
	     (let ((p wp))
	       (let-values
		   (((p state)
		     (do-send-message 'publisher (cons evt message) p state)))
		 (if p
		     (inject-process state p)
		     state))))))
     (cons (wrap-evt evt evt-handler) acc)]
    [_ acc]))